commit 32b9fe29acd8e263d0ad8de2a650e45f824db142 parent 6ac6b8d0a1c20b779fb332381b5495d9edf24205 Author: therealFIGBERT <naomi@FIGBERT-Mini.local> Date: Mon, 8 Jul 2019 18:23:39 -1000 Fixed MacOS .app bundle crashing issue, brought bundle up to date with scripts Diffstat:
478 files changed, 847 insertions(+), 19867 deletions(-)
diff --git a/MacOS/deprecated_bundle.app/Contents/Info.plist b/MacOS/deprecated_bundle.app/Contents/Info.plist @@ -1,22 +0,0 @@ -<?xml version="1.0" encoding="UTF-8"?> -<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> -<plist version="1.0"> -<dict> - <key>CFBundleDisplayName</key> - <string>figENC</string> - <key>CFBundleExecutable</key> - <string>MacOS/figENC</string> - <key>CFBundleIconFile</key> - <string>icon-windowed.icns</string> - <key>CFBundleIdentifier</key> - <string>figENC</string> - <key>CFBundleInfoDictionaryVersion</key> - <string>6.0</string> - <key>CFBundleName</key> - <string>figENC</string> - <key>CFBundlePackageType</key> - <string>APPL</string> - <key>CFBundleShortVersionString</key> - <string>0.0.0</string> -</dict> -</plist> diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/base_library.zip b/MacOS/deprecated_bundle.app/Contents/MacOS/base_library.zip Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/cryptography-2.7-py3.7.egg-info b/MacOS/deprecated_bundle.app/Contents/MacOS/cryptography-2.7-py3.7.egg-info @@ -1 +0,0 @@ -../Resources/cryptography-2.7-py3.7.egg-info -\ No newline at end of file diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/figENC b/MacOS/deprecated_bundle.app/Contents/MacOS/figENC Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/init.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/init.tcl @@ -1,819 +0,0 @@ -# init.tcl -- -# -# Default system startup file for Tcl-based applications. Defines -# "unknown" procedure and auto-load facilities. -# -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 Scriptics Corporation. -# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# - -# This test intentionally written in pre-7.5 Tcl -if {[info commands package] == ""} { - error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" -} -package require -exact Tcl 8.6.8 - -# Compute the auto path to use in this interpreter. -# The values on the path come from several locations: -# -# The environment variable TCLLIBPATH -# -# tcl_library, which is the directory containing this init.tcl script. -# [tclInit] (Tcl_Init()) searches around for the directory containing this -# init.tcl and defines tcl_library to that location before sourcing it. -# -# The parent directory of tcl_library. Adding the parent -# means that packages in peer directories will be found automatically. -# -# Also add the directory ../lib relative to the directory where the -# executable is located. This is meant to find binary packages for the -# same architecture as the current executable. -# -# tcl_pkgPath, which is set by the platform-specific initialization routines -# On UNIX it is compiled in -# On Windows, it is not used - -if {![info exists auto_path]} { - if {[info exists env(TCLLIBPATH)]} { - set auto_path $env(TCLLIBPATH) - } else { - set auto_path "" - } -} -namespace eval tcl { - variable Dir - foreach Dir [list $::tcl_library [file dirname $::tcl_library]] { - if {$Dir ni $::auto_path} { - lappend ::auto_path $Dir - } - } - set Dir [file join [file dirname [file dirname \ - [info nameofexecutable]]] lib] - if {$Dir ni $::auto_path} { - lappend ::auto_path $Dir - } - catch { - foreach Dir $::tcl_pkgPath { - if {$Dir ni $::auto_path} { - lappend ::auto_path $Dir - } - } - } - - if {![interp issafe]} { - variable Path [encoding dirs] - set Dir [file join $::tcl_library encoding] - if {$Dir ni $Path} { - lappend Path $Dir - encoding dirs $Path - } - } - - # TIP #255 min and max functions - namespace eval mathfunc { - proc min {args} { - if {![llength $args]} { - return -code error \ - "too few arguments to math function \"min\"" - } - set val Inf - foreach arg $args { - # This will handle forcing the numeric value without - # ruining the internal type of a numeric object - if {[catch {expr {double($arg)}} err]} { - return -code error $err - } - if {$arg < $val} {set val $arg} - } - return $val - } - proc max {args} { - if {![llength $args]} { - return -code error \ - "too few arguments to math function \"max\"" - } - set val -Inf - foreach arg $args { - # This will handle forcing the numeric value without - # ruining the internal type of a numeric object - if {[catch {expr {double($arg)}} err]} { - return -code error $err - } - if {$arg > $val} {set val $arg} - } - return $val - } - namespace export min max - } -} - -# Windows specific end of initialization - -if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { - namespace eval tcl { - proc EnvTraceProc {lo n1 n2 op} { - global env - set x $env($n2) - set env($lo) $x - set env([string toupper $lo]) $x - } - proc InitWinEnv {} { - global env tcl_platform - foreach p [array names env] { - set u [string toupper $p] - if {$u ne $p} { - switch -- $u { - COMSPEC - - PATH { - set temp $env($p) - unset env($p) - set env($u) $temp - trace add variable env($p) write \ - [namespace code [list EnvTraceProc $p]] - trace add variable env($u) write \ - [namespace code [list EnvTraceProc $p]] - } - } - } - } - if {![info exists env(COMSPEC)]} { - set env(COMSPEC) cmd.exe - } - } - InitWinEnv - } -} - -# Setup the unknown package handler - - -if {[interp issafe]} { - package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} -} else { - # Set up search for Tcl Modules (TIP #189). - # and setup platform specific unknown package handlers - if {$tcl_platform(os) eq "Darwin" - && $tcl_platform(platform) eq "unix"} { - package unknown {::tcl::tm::UnknownHandler \ - {::tcl::MacOSXPkgUnknown ::tclPkgUnknown}} - } else { - package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} - } - - # Set up the 'clock' ensemble - - namespace eval ::tcl::clock [list variable TclLibDir $::tcl_library] - - proc ::tcl::initClock {} { - # Auto-loading stubs for 'clock.tcl' - - foreach cmd {add format scan} { - proc ::tcl::clock::$cmd args { - variable TclLibDir - source -encoding utf-8 [file join $TclLibDir clock.tcl] - return [uplevel 1 [info level 0]] - } - } - - rename ::tcl::initClock {} - } - ::tcl::initClock -} - -# Conditionalize for presence of exec. - -if {[namespace which -command exec] eq ""} { - - # Some machines do not have exec. Also, on all - # platforms, safe interpreters do not have exec. - - set auto_noexec 1 -} - -# Define a log command (which can be overwitten to log errors -# differently, specially when stderr is not available) - -if {[namespace which -command tclLog] eq ""} { - proc tclLog {string} { - catch {puts stderr $string} - } -} - -# unknown -- -# This procedure is called when a Tcl command is invoked that doesn't -# exist in the interpreter. It takes the following steps to make the -# command available: -# -# 1. See if the autoload facility can locate the command in a -# Tcl script file. If so, load it and execute it. -# 2. If the command was invoked interactively at top-level: -# (a) see if the command exists as an executable UNIX program. -# If so, "exec" the command. -# (b) see if the command requests csh-like history substitution -# in one of the common forms !!, !<number>, or ^old^new. If -# so, emulate csh's history substitution. -# (c) see if the command is a unique abbreviation for another -# command. If so, invoke the command. -# -# Arguments: -# args - A list whose elements are the words of the original -# command, including the command name. - -proc unknown args { - variable ::tcl::UnknownPending - global auto_noexec auto_noload env tcl_interactive errorInfo errorCode - - if {[info exists errorInfo]} { - set savedErrorInfo $errorInfo - } - if {[info exists errorCode]} { - set savedErrorCode $errorCode - } - - set name [lindex $args 0] - if {![info exists auto_noload]} { - # - # Make sure we're not trying to load the same proc twice. - # - if {[info exists UnknownPending($name)]} { - return -code error "self-referential recursion\ - in \"unknown\" for command \"$name\"" - } - set UnknownPending($name) pending - set ret [catch { - auto_load $name [uplevel 1 {::namespace current}] - } msg opts] - unset UnknownPending($name) - if {$ret != 0} { - dict append opts -errorinfo "\n (autoloading \"$name\")" - return -options $opts $msg - } - if {![array size UnknownPending]} { - unset UnknownPending - } - if {$msg} { - if {[info exists savedErrorCode]} { - set ::errorCode $savedErrorCode - } else { - unset -nocomplain ::errorCode - } - if {[info exists savedErrorInfo]} { - set errorInfo $savedErrorInfo - } else { - unset -nocomplain errorInfo - } - set code [catch {uplevel 1 $args} msg opts] - if {$code == 1} { - # - # Compute stack trace contribution from the [uplevel]. - # Note the dependence on how Tcl_AddErrorInfo, etc. - # construct the stack trace. - # - set errInfo [dict get $opts -errorinfo] - set errCode [dict get $opts -errorcode] - set cinfo $args - if {[string bytelength $cinfo] > 150} { - set cinfo [string range $cinfo 0 150] - while {[string bytelength $cinfo] > 150} { - set cinfo [string range $cinfo 0 end-1] - } - append cinfo ... - } - set tail "\n (\"uplevel\" body line 1)\n invoked\ - from within\n\"uplevel 1 \$args\"" - set expect "$msg\n while executing\n\"$cinfo\"$tail" - if {$errInfo eq $expect} { - # - # The stack has only the eval from the expanded command - # Do not generate any stack trace here. - # - dict unset opts -errorinfo - dict incr opts -level - return -options $opts $msg - } - # - # Stack trace is nested, trim off just the contribution - # from the extra "eval" of $args due to the "catch" above. - # - set last [string last $tail $errInfo] - if {$last + [string length $tail] != [string length $errInfo]} { - # Very likely cannot happen - return -options $opts $msg - } - set errInfo [string range $errInfo 0 $last-1] - set tail "\"$cinfo\"" - set last [string last $tail $errInfo] - if {$last + [string length $tail] != [string length $errInfo]} { - return -code error -errorcode $errCode \ - -errorinfo $errInfo $msg - } - set errInfo [string range $errInfo 0 $last-1] - set tail "\n invoked from within\n" - set last [string last $tail $errInfo] - if {$last + [string length $tail] == [string length $errInfo]} { - return -code error -errorcode $errCode \ - -errorinfo [string range $errInfo 0 $last-1] $msg - } - set tail "\n while executing\n" - set last [string last $tail $errInfo] - if {$last + [string length $tail] == [string length $errInfo]} { - return -code error -errorcode $errCode \ - -errorinfo [string range $errInfo 0 $last-1] $msg - } - return -options $opts $msg - } else { - dict incr opts -level - return -options $opts $msg - } - } - } - - if {([info level] == 1) && ([info script] eq "") - && [info exists tcl_interactive] && $tcl_interactive} { - if {![info exists auto_noexec]} { - set new [auto_execok $name] - if {$new ne ""} { - set redir "" - if {[namespace which -command console] eq ""} { - set redir ">&@stdout <@stdin" - } - uplevel 1 [list ::catch \ - [concat exec $redir $new [lrange $args 1 end]] \ - ::tcl::UnknownResult ::tcl::UnknownOptions] - dict incr ::tcl::UnknownOptions -level - return -options $::tcl::UnknownOptions $::tcl::UnknownResult - } - } - if {$name eq "!!"} { - set newcmd [history event] - } elseif {[regexp {^!(.+)$} $name -> event]} { - set newcmd [history event $event] - } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} { - set newcmd [history event -1] - catch {regsub -all -- $old $newcmd $new newcmd} - } - if {[info exists newcmd]} { - tclLog $newcmd - history change $newcmd 0 - uplevel 1 [list ::catch $newcmd \ - ::tcl::UnknownResult ::tcl::UnknownOptions] - dict incr ::tcl::UnknownOptions -level - return -options $::tcl::UnknownOptions $::tcl::UnknownResult - } - - set ret [catch {set candidates [info commands $name*]} msg] - if {$name eq "::"} { - set name "" - } - if {$ret != 0} { - dict append opts -errorinfo \ - "\n (expanding command prefix \"$name\" in unknown)" - return -options $opts $msg - } - # Filter out bogus matches when $name contained - # a glob-special char [Bug 946952] - if {$name eq ""} { - # Handle empty $name separately due to strangeness - # in [string first] (See RFE 1243354) - set cmds $candidates - } else { - set cmds [list] - foreach x $candidates { - if {[string first $name $x] == 0} { - lappend cmds $x - } - } - } - if {[llength $cmds] == 1} { - uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ - ::tcl::UnknownResult ::tcl::UnknownOptions] - dict incr ::tcl::UnknownOptions -level - return -options $::tcl::UnknownOptions $::tcl::UnknownResult - } - if {[llength $cmds]} { - return -code error "ambiguous command name \"$name\": [lsort $cmds]" - } - } - return -code error -errorcode [list TCL LOOKUP COMMAND $name] \ - "invalid command name \"$name\"" -} - -# auto_load -- -# Checks a collection of library directories to see if a procedure -# is defined in one of them. If so, it sources the appropriate -# library file to create the procedure. Returns 1 if it successfully -# loaded the procedure, 0 otherwise. -# -# Arguments: -# cmd - Name of the command to find and load. -# namespace (optional) The namespace where the command is being used - must be -# a canonical namespace as returned [namespace current] -# for instance. If not given, namespace current is used. - -proc auto_load {cmd {namespace {}}} { - global auto_index auto_path - - if {$namespace eq ""} { - set namespace [uplevel 1 [list ::namespace current]] - } - set nameList [auto_qualify $cmd $namespace] - # workaround non canonical auto_index entries that might be around - # from older auto_mkindex versions - lappend nameList $cmd - foreach name $nameList { - if {[info exists auto_index($name)]} { - namespace eval :: $auto_index($name) - # There's a couple of ways to look for a command of a given - # name. One is to use - # info commands $name - # Unfortunately, if the name has glob-magic chars in it like * - # or [], it may not match. For our purposes here, a better - # route is to use - # namespace which -command $name - if {[namespace which -command $name] ne ""} { - return 1 - } - } - } - if {![info exists auto_path]} { - return 0 - } - - if {![auto_load_index]} { - return 0 - } - foreach name $nameList { - if {[info exists auto_index($name)]} { - namespace eval :: $auto_index($name) - if {[namespace which -command $name] ne ""} { - return 1 - } - } - } - return 0 -} - -# auto_load_index -- -# Loads the contents of tclIndex files on the auto_path directory -# list. This is usually invoked within auto_load to load the index -# of available commands. Returns 1 if the index is loaded, and 0 if -# the index is already loaded and up to date. -# -# Arguments: -# None. - -proc auto_load_index {} { - variable ::tcl::auto_oldpath - global auto_index auto_path - - if {[info exists auto_oldpath] && ($auto_oldpath eq $auto_path)} { - return 0 - } - set auto_oldpath $auto_path - - # Check if we are a safe interpreter. In that case, we support only - # newer format tclIndex files. - - set issafe [interp issafe] - for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} { - set dir [lindex $auto_path $i] - set f "" - if {$issafe} { - catch {source [file join $dir tclIndex]} - } elseif {[catch {set f [open [file join $dir tclIndex]]}]} { - continue - } else { - set error [catch { - set id [gets $f] - if {$id eq "# Tcl autoload index file, version 2.0"} { - eval [read $f] - } elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} { - while {[gets $f line] >= 0} { - if {([string index $line 0] eq "#") \ - || ([llength $line] != 2)} { - continue - } - set name [lindex $line 0] - set auto_index($name) \ - "source [file join $dir [lindex $line 1]]" - } - } else { - error "[file join $dir tclIndex] isn't a proper Tcl index file" - } - } msg opts] - if {$f ne ""} { - close $f - } - if {$error} { - return -options $opts $msg - } - } - } - return 1 -} - -# auto_qualify -- -# -# Compute a fully qualified names list for use in the auto_index array. -# For historical reasons, commands in the global namespace do not have leading -# :: in the index key. The list has two elements when the command name is -# relative (no leading ::) and the namespace is not the global one. Otherwise -# only one name is returned (and searched in the auto_index). -# -# Arguments - -# cmd The command name. Can be any name accepted for command -# invocations (Like "foo::::bar"). -# namespace The namespace where the command is being used - must be -# a canonical namespace as returned by [namespace current] -# for instance. - -proc auto_qualify {cmd namespace} { - - # count separators and clean them up - # (making sure that foo:::::bar will be treated as foo::bar) - set n [regsub -all {::+} $cmd :: cmd] - - # Ignore namespace if the name starts with :: - # Handle special case of only leading :: - - # Before each return case we give an example of which category it is - # with the following form : - # (inputCmd, inputNameSpace) -> output - - if {[string match ::* $cmd]} { - if {$n > 1} { - # (::foo::bar , *) -> ::foo::bar - return [list $cmd] - } else { - # (::global , *) -> global - return [list [string range $cmd 2 end]] - } - } - - # Potentially returning 2 elements to try : - # (if the current namespace is not the global one) - - if {$n == 0} { - if {$namespace eq "::"} { - # (nocolons , ::) -> nocolons - return [list $cmd] - } else { - # (nocolons , ::sub) -> ::sub::nocolons nocolons - return [list ${namespace}::$cmd $cmd] - } - } elseif {$namespace eq "::"} { - # (foo::bar , ::) -> ::foo::bar - return [list ::$cmd] - } else { - # (foo::bar , ::sub) -> ::sub::foo::bar ::foo::bar - return [list ${namespace}::$cmd ::$cmd] - } -} - -# auto_import -- -# -# Invoked during "namespace import" to make see if the imported commands -# reside in an autoloaded library. If so, the commands are loaded so -# that they will be available for the import links. If not, then this -# procedure does nothing. -# -# Arguments - -# pattern The pattern of commands being imported (like "foo::*") -# a canonical namespace as returned by [namespace current] - -proc auto_import {pattern} { - global auto_index - - # If no namespace is specified, this will be an error case - - if {![string match *::* $pattern]} { - return - } - - set ns [uplevel 1 [list ::namespace current]] - set patternList [auto_qualify $pattern $ns] - - auto_load_index - - foreach pattern $patternList { - foreach name [array names auto_index $pattern] { - if {([namespace which -command $name] eq "") - && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} { - namespace eval :: $auto_index($name) - } - } - } -} - -# auto_execok -- -# -# Returns string that indicates name of program to execute if -# name corresponds to a shell builtin or an executable in the -# Windows search path, or "" otherwise. Builds an associative -# array auto_execs that caches information about previous checks, -# for speed. -# -# Arguments: -# name - Name of a command. - -if {$tcl_platform(platform) eq "windows"} { -# Windows version. -# -# Note that file executable doesn't work under Windows, so we have to -# look for files with .exe, .com, or .bat extensions. Also, the path -# may be in the Path or PATH environment variables, and path -# components are separated with semicolons, not colons as under Unix. -# -proc auto_execok name { - global auto_execs env tcl_platform - - if {[info exists auto_execs($name)]} { - return $auto_execs($name) - } - set auto_execs($name) "" - - set shellBuiltins [list assoc cls copy date del dir echo erase ftype \ - md mkdir mklink move rd ren rename rmdir start time type ver vol] - if {[info exists env(PATHEXT)]} { - # Add an initial ; to have the {} extension check first. - set execExtensions [split ";$env(PATHEXT)" ";"] - } else { - set execExtensions [list {} .com .exe .bat .cmd] - } - - if {[string tolower $name] in $shellBuiltins} { - # When this is command.com for some reason on Win2K, Tcl won't - # exec it unless the case is right, which this corrects. COMSPEC - # may not point to a real file, so do the check. - set cmd $env(COMSPEC) - if {[file exists $cmd]} { - set cmd [file attributes $cmd -shortname] - } - return [set auto_execs($name) [list $cmd /c $name]] - } - - if {[llength [file split $name]] != 1} { - foreach ext $execExtensions { - set file ${name}${ext} - if {[file exists $file] && ![file isdirectory $file]} { - return [set auto_execs($name) [list $file]] - } - } - return "" - } - - set path "[file dirname [info nameof]];.;" - if {[info exists env(WINDIR)]} { - set windir $env(WINDIR) - } - if {[info exists windir]} { - if {$tcl_platform(os) eq "Windows NT"} { - append path "$windir/system32;" - } - append path "$windir/system;$windir;" - } - - foreach var {PATH Path path} { - if {[info exists env($var)]} { - append path ";$env($var)" - } - } - - foreach ext $execExtensions { - unset -nocomplain checked - foreach dir [split $path {;}] { - # Skip already checked directories - if {[info exists checked($dir)] || ($dir eq "")} { - continue - } - set checked($dir) {} - set file [file join $dir ${name}${ext}] - if {[file exists $file] && ![file isdirectory $file]} { - return [set auto_execs($name) [list $file]] - } - } - } - return "" -} - -} else { -# Unix version. -# -proc auto_execok name { - global auto_execs env - - if {[info exists auto_execs($name)]} { - return $auto_execs($name) - } - set auto_execs($name) "" - if {[llength [file split $name]] != 1} { - if {[file executable $name] && ![file isdirectory $name]} { - set auto_execs($name) [list $name] - } - return $auto_execs($name) - } - foreach dir [split $env(PATH) :] { - if {$dir eq ""} { - set dir . - } - set file [file join $dir $name] - if {[file executable $file] && ![file isdirectory $file]} { - set auto_execs($name) [list $file] - return $auto_execs($name) - } - } - return "" -} - -} - -# ::tcl::CopyDirectory -- -# -# This procedure is called by Tcl's core when attempts to call the -# filesystem's copydirectory function fail. The semantics of the call -# are that 'dest' does not yet exist, i.e. dest should become the exact -# image of src. If dest does exist, we throw an error. -# -# Note that making changes to this procedure can change the results -# of running Tcl's tests. -# -# Arguments: -# action - "renaming" or "copying" -# src - source directory -# dest - destination directory -proc tcl::CopyDirectory {action src dest} { - set nsrc [file normalize $src] - set ndest [file normalize $dest] - - if {$action eq "renaming"} { - # Can't rename volumes. We could give a more precise - # error message here, but that would break the test suite. - if {$nsrc in [file volumes]} { - return -code error "error $action \"$src\" to\ - \"$dest\": trying to rename a volume or move a directory\ - into itself" - } - } - if {[file exists $dest]} { - if {$nsrc eq $ndest} { - return -code error "error $action \"$src\" to\ - \"$dest\": trying to rename a volume or move a directory\ - into itself" - } - if {$action eq "copying"} { - # We used to throw an error here, but, looking more closely - # at the core copy code in tclFCmd.c, if the destination - # exists, then we should only call this function if -force - # is true, which means we just want to over-write. So, - # the following code is now commented out. - # - # return -code error "error $action \"$src\" to\ - # \"$dest\": file already exists" - } else { - # Depending on the platform, and on the current - # working directory, the directories '.', '..' - # can be returned in various combinations. Anyway, - # if any other file is returned, we must signal an error. - set existing [glob -nocomplain -directory $dest * .*] - lappend existing {*}[glob -nocomplain -directory $dest \ - -type hidden * .*] - foreach s $existing { - if {[file tail $s] ni {. ..}} { - return -code error "error $action \"$src\" to\ - \"$dest\": file already exists" - } - } - } - } else { - if {[string first $nsrc $ndest] != -1} { - set srclen [expr {[llength [file split $nsrc]] - 1}] - set ndest [lindex [file split $ndest] $srclen] - if {$ndest eq [file tail $nsrc]} { - return -code error "error $action \"$src\" to\ - \"$dest\": trying to rename a volume or move a directory\ - into itself" - } - } - file mkdir $dest - } - # Have to be careful to capture both visible and hidden files. - # We will also be more generous to the file system and not - # assume the hidden and non-hidden lists are non-overlapping. - # - # On Unix 'hidden' files begin with '.'. On other platforms - # or filesystems hidden files may have other interpretations. - set filelist [concat [glob -nocomplain -directory $src *] \ - [glob -nocomplain -directory $src -types hidden *]] - - foreach s [lsort -unique $filelist] { - if {[file tail $s] ni {. ..}} { - file copy -force -- $s [file join $dest [file tail $s]] - } - } - return -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8/8.4/platform-1.0.14.tm b/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8/8.4/platform-1.0.14.tm @@ -1,397 +0,0 @@ -# -*- tcl -*- -# ### ### ### ######### ######### ######### -## Overview - -# Heuristics to assemble a platform identifier from publicly available -# information. The identifier describes the platform of the currently -# running tcl shell. This is a mixture of the runtime environment and -# of build-time properties of the executable itself. -# -# Examples: -# <1> A tcl shell executing on a x86_64 processor, but having a -# wordsize of 4 was compiled for the x86 environment, i.e. 32 -# bit, and loaded packages have to match that, and not the -# actual cpu. -# -# <2> The hp/solaris 32/64 bit builds of the core cannot be -# distinguished by looking at tcl_platform. As packages have to -# match the 32/64 information we have to look in more places. In -# this case we inspect the executable itself (magic numbers, -# i.e. fileutil::magic::filetype). -# -# The basic information used comes out of the 'os' and 'machine' -# entries of the 'tcl_platform' array. A number of general and -# os/machine specific transformation are applied to get a canonical -# result. -# -# General -# Only the first element of 'os' is used - we don't care whether we -# are on "Windows NT" or "Windows XP" or whatever. -# -# Machine specific -# % arm* -> arm -# % sun4* -> sparc -# % intel -> ix86 -# % i*86* -> ix86 -# % Power* -> powerpc -# % x86_64 + wordSize 4 => x86 code -# -# OS specific -# % AIX are always powerpc machines -# % HP-UX 9000/800 etc means parisc -# % linux has to take glibc version into account -# % sunos -> solaris, and keep version number -# -# NOTE: A platform like linux glibc 2.3, which can use glibc 2.2 stuff -# has to provide all possible allowed platform identifiers when -# searching search. Ditto a solaris 2.8 platform can use solaris 2.6 -# packages. Etc. This is handled by the other procedure, see below. - -# ### ### ### ######### ######### ######### -## Requirements - -namespace eval ::platform {} - -# ### ### ### ######### ######### ######### -## Implementation - -# -- platform::generic -# -# Assembles an identifier for the generic platform. It leaves out -# details like kernel version, libc version, etc. - -proc ::platform::generic {} { - global tcl_platform - - set plat [string tolower [lindex $tcl_platform(os) 0]] - set cpu $tcl_platform(machine) - - switch -glob -- $cpu { - sun4* { - set cpu sparc - } - intel - - i*86* { - set cpu ix86 - } - x86_64 { - if {$tcl_platform(wordSize) == 4} { - # See Example <1> at the top of this file. - set cpu ix86 - } - } - "Power*" { - set cpu powerpc - } - "arm*" { - set cpu arm - } - ia64 { - if {$tcl_platform(wordSize) == 4} { - append cpu _32 - } - } - } - - switch -glob -- $plat { - cygwin* { - set plat cygwin - } - windows { - if {$tcl_platform(platform) == "unix"} { - set plat cygwin - } else { - set plat win32 - } - if {$cpu eq "amd64"} { - # Do not check wordSize, win32-x64 is an IL32P64 platform. - set cpu x86_64 - } - } - sunos { - set plat solaris - if {[string match "ix86" $cpu]} { - if {$tcl_platform(wordSize) == 8} { - set cpu x86_64 - } - } elseif {![string match "ia64*" $cpu]} { - # sparc - if {$tcl_platform(wordSize) == 8} { - append cpu 64 - } - } - } - darwin { - set plat macosx - # Correctly identify the cpu when running as a 64bit - # process on a machine with a 32bit kernel - if {$cpu eq "ix86"} { - if {$tcl_platform(wordSize) == 8} { - set cpu x86_64 - } - } - } - aix { - set cpu powerpc - if {$tcl_platform(wordSize) == 8} { - append cpu 64 - } - } - hp-ux { - set plat hpux - if {![string match "ia64*" $cpu]} { - set cpu parisc - if {$tcl_platform(wordSize) == 8} { - append cpu 64 - } - } - } - osf1 { - set plat tru64 - } - } - - return "${plat}-${cpu}" -} - -# -- platform::identify -# -# Assembles an identifier for the exact platform, by extending the -# generic identifier. I.e. it adds in details like kernel version, -# libc version, etc., if they are relevant for the loading of -# packages on the platform. - -proc ::platform::identify {} { - global tcl_platform - - set id [generic] - regexp {^([^-]+)-([^-]+)$} $id -> plat cpu - - switch -- $plat { - solaris { - regsub {^5} $tcl_platform(osVersion) 2 text - append plat $text - return "${plat}-${cpu}" - } - macosx { - set major [lindex [split $tcl_platform(osVersion) .] 0] - if {$major > 8} { - incr major -4 - append plat 10.$major - return "${plat}-${cpu}" - } - } - linux { - # Look for the libc*.so and determine its version - # (libc5/6, libc6 further glibc 2.X) - - set v unknown - - # Determine in which directory to look. /lib, or /lib64. - # For that we use the tcl_platform(wordSize). - # - # We could use the 'cpu' info, per the equivalence below, - # that however would be restricted to intel. And this may - # be a arm, mips, etc. system. The wordsize is more - # fundamental. - # - # ix86 <=> (wordSize == 4) <=> 32 bit ==> /lib - # x86_64 <=> (wordSize == 8) <=> 64 bit ==> /lib64 - # - # Do not look into /lib64 even if present, if the cpu - # doesn't fit. - - # TODO: Determine the prefixes (i386, x86_64, ...) for - # other cpus. The path after the generic one is utterly - # specific to intel right now. Ok, on Ubuntu, possibly - # other Debian systems we may apparently be able to query - # the necessary CPU code. If we can't we simply use the - # hardwired fallback. - - switch -exact -- $tcl_platform(wordSize) { - 4 { - lappend bases /lib - if {[catch { - exec dpkg-architecture -qDEB_HOST_MULTIARCH - } res]} { - lappend bases /lib/i386-linux-gnu - } else { - # dpkg-arch returns the full tripled, not just cpu. - lappend bases /lib/$res - } - } - 8 { - lappend bases /lib64 - if {[catch { - exec dpkg-architecture -qDEB_HOST_MULTIARCH - } res]} { - lappend bases /lib/x86_64-linux-gnu - } else { - # dpkg-arch returns the full tripled, not just cpu. - lappend bases /lib/$res - } - } - default { - return -code error "Bad wordSize $tcl_platform(wordSize), expected 4 or 8" - } - } - - foreach base $bases { - if {[LibcVersion $base -> v]} break - } - - append plat -$v - return "${plat}-${cpu}" - } - } - - return $id -} - -proc ::platform::LibcVersion {base _->_ vv} { - upvar 1 $vv v - set libclist [lsort [glob -nocomplain -directory $base libc*]] - - if {![llength $libclist]} { return 0 } - - set libc [lindex $libclist 0] - - # Try executing the library first. This should suceed - # for a glibc library, and return the version - # information. - - if {![catch { - set vdata [lindex [split [exec $libc] \n] 0] - }]} { - regexp {version ([0-9]+(\.[0-9]+)*)} $vdata -> v - foreach {major minor} [split $v .] break - set v glibc${major}.${minor} - return 1 - } else { - # We had trouble executing the library. We are now - # inspecting its name to determine the version - # number. This code by Larry McVoy. - - if {[regexp -- {libc-([0-9]+)\.([0-9]+)} $libc -> major minor]} { - set v glibc${major}.${minor} - return 1 - } - } - return 0 -} - -# -- platform::patterns -# -# Given an exact platform identifier, i.e. _not_ the generic -# identifier it assembles a list of exact platform identifier -# describing platform which should be compatible with the -# input. -# -# I.e. packages for all platforms in the result list should be -# loadable on the specified platform. - -# << Should we add the generic identifier to the list as well ? In -# general it is not compatible I believe. So better not. In many -# cases the exact identifier is identical to the generic one -# anyway. -# >> - -proc ::platform::patterns {id} { - set res [list $id] - if {$id eq "tcl"} {return $res} - - switch -glob -- $id { - solaris*-* { - if {[regexp {solaris([^-]*)-(.*)} $id -> v cpu]} { - if {$v eq ""} {return $id} - foreach {major minor} [split $v .] break - incr minor -1 - for {set j $minor} {$j >= 6} {incr j -1} { - lappend res solaris${major}.${j}-${cpu} - } - } - } - linux*-* { - if {[regexp {linux-glibc([^-]*)-(.*)} $id -> v cpu]} { - foreach {major minor} [split $v .] break - incr minor -1 - for {set j $minor} {$j >= 0} {incr j -1} { - lappend res linux-glibc${major}.${j}-${cpu} - } - } - } - macosx-powerpc { - lappend res macosx-universal - } - macosx-x86_64 { - lappend res macosx-i386-x86_64 - } - macosx-ix86 { - lappend res macosx-universal macosx-i386-x86_64 - } - macosx*-* { - # 10.5+ - if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} { - - switch -exact -- $cpu { - ix86 { - lappend alt i386-x86_64 - lappend alt universal - } - x86_64 { lappend alt i386-x86_64 } - default { set alt {} } - } - - if {$v ne ""} { - foreach {major minor} [split $v .] break - - # Add 10.5 to 10.minor to patterns. - set res {} - for {set j $minor} {$j >= 5} {incr j -1} { - lappend res macosx${major}.${j}-${cpu} - foreach a $alt { - lappend res macosx${major}.${j}-$a - } - } - - # Add unversioned patterns for 10.3/10.4 builds. - lappend res macosx-${cpu} - foreach a $alt { - lappend res macosx-$a - } - } else { - # No version, just do unversioned patterns. - foreach a $alt { - lappend res macosx-$a - } - } - } else { - # no v, no cpu ... nothing - } - } - } - lappend res tcl ; # Pure tcl packages are always compatible. - return $res -} - - -# ### ### ### ######### ######### ######### -## Ready - -package provide platform 1.0.14 - -# ### ### ### ######### ######### ######### -## Demo application - -if {[info exists argv0] && ($argv0 eq [info script])} { - puts ==================================== - parray tcl_platform - puts ==================================== - puts Generic\ identification:\ [::platform::generic] - puts Exact\ identification:\ \ \ [::platform::identify] - puts ==================================== - puts Search\ patterns: - puts *\ [join [::platform::patterns [::platform::identify]] \n*\ ] - puts ==================================== - exit 0 -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8/8.4/platform/shell-1.1.4.tm b/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8/8.4/platform/shell-1.1.4.tm @@ -1,241 +0,0 @@ - -# -*- tcl -*- -# ### ### ### ######### ######### ######### -## Overview - -# Higher-level commands which invoke the functionality of this package -# for an arbitrary tcl shell (tclsh, wish, ...). This is required by a -# repository as while the tcl shell executing packages uses the same -# platform in general as a repository application there can be -# differences in detail (i.e. 32/64 bit builds). - -# ### ### ### ######### ######### ######### -## Requirements - -package require platform -namespace eval ::platform::shell {} - -# ### ### ### ######### ######### ######### -## Implementation - -# -- platform::shell::generic - -proc ::platform::shell::generic {shell} { - # Argument is the path to a tcl shell. - - CHECK $shell - LOCATE base out - - set code {} - # Forget any pre-existing platform package, it might be in - # conflict with this one. - lappend code {package forget platform} - # Inject our platform package - lappend code [list source $base] - # Query and print the architecture - lappend code {puts [platform::generic]} - # And done - lappend code {exit 0} - - set arch [RUN $shell [join $code \n]] - - if {$out} {file delete -force $base} - return $arch -} - -# -- platform::shell::identify - -proc ::platform::shell::identify {shell} { - # Argument is the path to a tcl shell. - - CHECK $shell - LOCATE base out - - set code {} - # Forget any pre-existing platform package, it might be in - # conflict with this one. - lappend code {package forget platform} - # Inject our platform package - lappend code [list source $base] - # Query and print the architecture - lappend code {puts [platform::identify]} - # And done - lappend code {exit 0} - - set arch [RUN $shell [join $code \n]] - - if {$out} {file delete -force $base} - return $arch -} - -# -- platform::shell::platform - -proc ::platform::shell::platform {shell} { - # Argument is the path to a tcl shell. - - CHECK $shell - - set code {} - lappend code {puts $tcl_platform(platform)} - lappend code {exit 0} - - return [RUN $shell [join $code \n]] -} - -# ### ### ### ######### ######### ######### -## Internal helper commands. - -proc ::platform::shell::CHECK {shell} { - if {![file exists $shell]} { - return -code error "Shell \"$shell\" does not exist" - } - if {![file executable $shell]} { - return -code error "Shell \"$shell\" is not executable (permissions)" - } - return -} - -proc ::platform::shell::LOCATE {bv ov} { - upvar 1 $bv base $ov out - - # Locate the platform package for injection into the specified - # shell. We are using package management to find it, whereever it - # is, instead of using hardwired relative paths. This allows us to - # install the two packages as TMs without breaking the code - # here. If the found package is wrapped we copy the code somewhere - # where the spawned shell will be able to read it. - - # This code is brittle, it needs has to adapt to whatever changes - # are made to the TM code, i.e. the provide statement generated by - # tm.tcl - - set pl [package ifneeded platform [package require platform]] - set base [lindex $pl end] - - set out 0 - if {[lindex [file system $base]] ne "native"} { - set temp [TEMP] - file copy -force $base $temp - set base $temp - set out 1 - } - return -} - -proc ::platform::shell::RUN {shell code} { - set c [TEMP] - set cc [open $c w] - puts $cc $code - close $cc - - set e [TEMP] - - set code [catch { - exec $shell $c 2> $e - } res] - - file delete $c - - if {$code} { - append res \n[read [set chan [open $e r]]][close $chan] - file delete $e - return -code error "Shell \"$shell\" is not executable ($res)" - } - - file delete $e - return $res -} - -proc ::platform::shell::TEMP {} { - set prefix platform - - # This code is copied out of Tcllib's fileutil package. - # (TempFile/tempfile) - - set tmpdir [DIR] - - set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" - set nrand_chars 10 - set maxtries 10 - set access [list RDWR CREAT EXCL TRUNC] - set permission 0600 - set channel "" - set checked_dir_writable 0 - set mypid [pid] - for {set i 0} {$i < $maxtries} {incr i} { - set newname $prefix - for {set j 0} {$j < $nrand_chars} {incr j} { - append newname [string index $chars \ - [expr {int(rand()*62)}]] - } - set newname [file join $tmpdir $newname] - if {[file exists $newname]} { - after 1 - } else { - if {[catch {open $newname $access $permission} channel]} { - if {!$checked_dir_writable} { - set dirname [file dirname $newname] - if {![file writable $dirname]} { - return -code error "Directory $dirname is not writable" - } - set checked_dir_writable 1 - } - } else { - # Success - close $channel - return [file normalize $newname] - } - } - } - if {$channel ne ""} { - return -code error "Failed to open a temporary file: $channel" - } else { - return -code error "Failed to find an unused temporary file name" - } -} - -proc ::platform::shell::DIR {} { - # This code is copied out of Tcllib's fileutil package. - # (TempDir/tempdir) - - global tcl_platform env - - set attempdirs [list] - - foreach tmp {TMPDIR TEMP TMP} { - if { [info exists env($tmp)] } { - lappend attempdirs $env($tmp) - } - } - - switch $tcl_platform(platform) { - windows { - lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" - } - macintosh { - set tmpdir $env(TRASH_FOLDER) ;# a better place? - } - default { - lappend attempdirs \ - [file join / tmp] \ - [file join / var tmp] \ - [file join / usr tmp] - } - } - - lappend attempdirs [pwd] - - foreach tmp $attempdirs { - if { [file isdirectory $tmp] && [file writable $tmp] } { - return [file normalize $tmp] - } - } - - # Fail if nothing worked. - return -code error "Unable to determine a proper directory for temporary files" -} - -# ### ### ### ######### ######### ######### -## Ready - -package provide platform::shell 1.1.4 diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8/8.5/msgcat-1.6.1.tm b/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8/8.5/msgcat-1.6.1.tm @@ -1,1210 +0,0 @@ -# msgcat.tcl -- -# -# This file defines various procedures which implement a -# message catalog facility for Tcl programs. It should be -# loaded with the command "package require msgcat". -# -# Copyright (c) 2010-2015 by Harald Oehlmann. -# Copyright (c) 1998-2000 by Ajuba Solutions. -# Copyright (c) 1998 by Mark Harrison. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -package require Tcl 8.5- -# When the version number changes, be sure to update the pkgIndex.tcl file, -# and the installation directory in the Makefiles. -package provide msgcat 1.6.1 - -namespace eval msgcat { - namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences mcset\ - mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\ - mcpackageconfig mcpackagelocale - - # Records the list of locales to search - variable Loclist {} - - # List of currently loaded locales - variable LoadedLocales {} - - # Records the locale of the currently sourced message catalogue file - variable FileLocale - - # Configuration values per Package (e.g. client namespace). - # The dict key is of the form "<option> <namespace>" and the value is the - # configuration option. A nonexisting key is an unset option. - variable PackageConfig [dict create mcfolder {} loadcmd {} changecmd {}\ - unknowncmd {} loadedlocales {} loclist {}] - - # Records the mapping between source strings and translated strings. The - # dict key is of the form "<namespace> <locale> <src>", where locale and - # namespace should be themselves dict values and the value is - # the translated string. - variable Msgs [dict create] - - # Map of language codes used in Windows registry to those of ISO-639 - if {[info sharedlibextension] eq ".dll"} { - variable WinRegToISO639 [dict create {*}{ - 01 ar 0401 ar_SA 0801 ar_IQ 0c01 ar_EG 1001 ar_LY 1401 ar_DZ - 1801 ar_MA 1c01 ar_TN 2001 ar_OM 2401 ar_YE 2801 ar_SY - 2c01 ar_JO 3001 ar_LB 3401 ar_KW 3801 ar_AE 3c01 ar_BH - 4001 ar_QA - 02 bg 0402 bg_BG - 03 ca 0403 ca_ES - 04 zh 0404 zh_TW 0804 zh_CN 0c04 zh_HK 1004 zh_SG 1404 zh_MO - 05 cs 0405 cs_CZ - 06 da 0406 da_DK - 07 de 0407 de_DE 0807 de_CH 0c07 de_AT 1007 de_LU 1407 de_LI - 08 el 0408 el_GR - 09 en 0409 en_US 0809 en_GB 0c09 en_AU 1009 en_CA 1409 en_NZ - 1809 en_IE 1c09 en_ZA 2009 en_JM 2409 en_GD 2809 en_BZ - 2c09 en_TT 3009 en_ZW 3409 en_PH - 0a es 040a es_ES 080a es_MX 0c0a es_ES@modern 100a es_GT 140a es_CR - 180a es_PA 1c0a es_DO 200a es_VE 240a es_CO 280a es_PE - 2c0a es_AR 300a es_EC 340a es_CL 380a es_UY 3c0a es_PY - 400a es_BO 440a es_SV 480a es_HN 4c0a es_NI 500a es_PR - 0b fi 040b fi_FI - 0c fr 040c fr_FR 080c fr_BE 0c0c fr_CA 100c fr_CH 140c fr_LU - 180c fr_MC - 0d he 040d he_IL - 0e hu 040e hu_HU - 0f is 040f is_IS - 10 it 0410 it_IT 0810 it_CH - 11 ja 0411 ja_JP - 12 ko 0412 ko_KR - 13 nl 0413 nl_NL 0813 nl_BE - 14 no 0414 no_NO 0814 nn_NO - 15 pl 0415 pl_PL - 16 pt 0416 pt_BR 0816 pt_PT - 17 rm 0417 rm_CH - 18 ro 0418 ro_RO 0818 ro_MO - 19 ru 0819 ru_MO - 1a hr 041a hr_HR 081a sr_YU 0c1a sr_YU@cyrillic - 1b sk 041b sk_SK - 1c sq 041c sq_AL - 1d sv 041d sv_SE 081d sv_FI - 1e th 041e th_TH - 1f tr 041f tr_TR - 20 ur 0420 ur_PK 0820 ur_IN - 21 id 0421 id_ID - 22 uk 0422 uk_UA - 23 be 0423 be_BY - 24 sl 0424 sl_SI - 25 et 0425 et_EE - 26 lv 0426 lv_LV - 27 lt 0427 lt_LT - 28 tg 0428 tg_TJ - 29 fa 0429 fa_IR - 2a vi 042a vi_VN - 2b hy 042b hy_AM - 2c az 042c az_AZ@latin 082c az_AZ@cyrillic - 2d eu - 2e wen 042e wen_DE - 2f mk 042f mk_MK - 30 bnt 0430 bnt_TZ - 31 ts 0431 ts_ZA - 32 tn - 33 ven 0433 ven_ZA - 34 xh 0434 xh_ZA - 35 zu 0435 zu_ZA - 36 af 0436 af_ZA - 37 ka 0437 ka_GE - 38 fo 0438 fo_FO - 39 hi 0439 hi_IN - 3a mt 043a mt_MT - 3b se 043b se_NO - 043c gd_UK 083c ga_IE - 3d yi 043d yi_IL - 3e ms 043e ms_MY 083e ms_BN - 3f kk 043f kk_KZ - 40 ky 0440 ky_KG - 41 sw 0441 sw_KE - 42 tk 0442 tk_TM - 43 uz 0443 uz_UZ@latin 0843 uz_UZ@cyrillic - 44 tt 0444 tt_RU - 45 bn 0445 bn_IN - 46 pa 0446 pa_IN - 47 gu 0447 gu_IN - 48 or 0448 or_IN - 49 ta - 4a te 044a te_IN - 4b kn 044b kn_IN - 4c ml 044c ml_IN - 4d as 044d as_IN - 4e mr 044e mr_IN - 4f sa 044f sa_IN - 50 mn - 51 bo 0451 bo_CN - 52 cy 0452 cy_GB - 53 km 0453 km_KH - 54 lo 0454 lo_LA - 55 my 0455 my_MM - 56 gl 0456 gl_ES - 57 kok 0457 kok_IN - 58 mni 0458 mni_IN - 59 sd - 5a syr 045a syr_TR - 5b si 045b si_LK - 5c chr 045c chr_US - 5d iu 045d iu_CA - 5e am 045e am_ET - 5f ber 045f ber_MA - 60 ks 0460 ks_PK 0860 ks_IN - 61 ne 0461 ne_NP 0861 ne_IN - 62 fy 0462 fy_NL - 63 ps - 64 tl 0464 tl_PH - 65 div 0465 div_MV - 66 bin 0466 bin_NG - 67 ful 0467 ful_NG - 68 ha 0468 ha_NG - 69 nic 0469 nic_NG - 6a yo 046a yo_NG - 70 ibo 0470 ibo_NG - 71 kau 0471 kau_NG - 72 om 0472 om_ET - 73 ti 0473 ti_ET - 74 gn 0474 gn_PY - 75 cpe 0475 cpe_US - 76 la 0476 la_VA - 77 so 0477 so_SO - 78 sit 0478 sit_CN - 79 pap 0479 pap_AN - }] - } -} - -# msgcat::mc -- -# -# Find the translation for the given string based on the current -# locale setting. Check the local namespace first, then look in each -# parent namespace until the source is found. If additional args are -# specified, use the format command to work them into the traslated -# string. -# If no catalog item is found, mcunknown is called in the caller frame -# and its result is returned. -# -# Arguments: -# src The string to translate. -# args Args to pass to the format command -# -# Results: -# Returns the translated string. Propagates errors thrown by the -# format command. - -proc msgcat::mc {src args} { - # this may be replaced by: - # return [mcget -namespace [uplevel 1 [list ::namespace current]] --\ - # $src {*}$args] - - # Check for the src in each namespace starting from the local and - # ending in the global. - - variable Msgs - variable Loclist - - set ns [uplevel 1 [list ::namespace current]] - set loclist [PackagePreferences $ns] - - set nscur $ns - while {$nscur != ""} { - foreach loc $loclist { - if {[dict exists $Msgs $nscur $loc $src]} { - return [DefaultUnknown "" [dict get $Msgs $nscur $loc $src]\ - {*}$args] - } - } - set nscur [namespace parent $nscur] - } - # call package local or default unknown command - set args [linsert $args 0 [lindex $loclist 0] $src] - switch -exact -- [Invoke unknowncmd $args $ns result 1] { - 0 { return [uplevel 1 [linsert $args 0 [namespace origin mcunknown]]] } - 1 { return [DefaultUnknown {*}$args] } - default { return $result } - } -} - -# msgcat::mcexists -- -# -# Check if a catalog item is set or if mc would invoke mcunknown. -# -# Arguments: -# -exactnamespace Only check the exact namespace and no -# parent namespaces -# -exactlocale Only check the exact locale and not all members -# of the preferences list -# src Message catalog key -# -# Results: -# true if an adequate catalog key was found - -proc msgcat::mcexists {args} { - - variable Msgs - variable Loclist - variable PackageConfig - - set ns [uplevel 1 [list ::namespace current]] - set loclist [PackagePreferences $ns] - - while {[llength $args] != 1} { - set args [lassign $args option] - switch -glob -- $option { - -exactnamespace { set exactnamespace 1 } - -exactlocale { set loclist [lrange $loclist 0 0] } - -* { return -code error "unknown option \"$option\"" } - default { - return -code error "wrong # args: should be\ - \"[lindex [info level 0] 0] ?-exactnamespace?\ - ?-exactlocale? src\"" - } - } - } - set src [lindex $args 0] - - while {$ns ne ""} { - foreach loc $loclist { - if {[dict exists $Msgs $ns $loc $src]} { - return 1 - } - } - if {[info exists exactnamespace]} {return 0} - set ns [namespace parent $ns] - } - return 0 -} - -# msgcat::mclocale -- -# -# Query or set the current locale. -# -# Arguments: -# newLocale (Optional) The new locale string. Locale strings -# should be composed of one or more sublocale parts -# separated by underscores (e.g. en_US). -# -# Results: -# Returns the normalized set locale. - -proc msgcat::mclocale {args} { - variable Loclist - variable LoadedLocales - set len [llength $args] - - if {$len > 1} { - return -code error "wrong # args: should be\ - \"[lindex [info level 0] 0] ?newLocale?\"" - } - - if {$len == 1} { - set newLocale [string tolower [lindex $args 0]] - if {$newLocale ne [file tail $newLocale]} { - return -code error "invalid newLocale value \"$newLocale\":\ - could be path to unsafe code." - } - if {[lindex $Loclist 0] ne $newLocale} { - set Loclist [GetPreferences $newLocale] - - # locale not loaded jet - LoadAll $Loclist - # Invoke callback - Invoke changecmd $Loclist - } - } - return [lindex $Loclist 0] -} - -# msgcat::GetPreferences -- -# -# Get list of locales from a locale. -# The first element is always the lowercase locale. -# Other elements have one component separated by "_" less. -# Multiple "_" are seen as one separator: de__ch_spec de__ch de {} -# -# Arguments: -# Locale. -# -# Results: -# Locale list - -proc msgcat::GetPreferences {locale} { - set locale [string tolower $locale] - set loclist [list $locale] - while {-1 !=[set pos [string last "_" $locale]]} { - set locale [string range $locale 0 $pos-1] - if { "_" ne [string index $locale end] } { - lappend loclist $locale - } - } - if {"" ne [lindex $loclist end]} { - lappend loclist {} - } - return $loclist -} - -# msgcat::mcpreferences -- -# -# Fetch the list of locales used to look up strings, ordered from -# most preferred to least preferred. -# -# Arguments: -# None. -# -# Results: -# Returns an ordered list of the locales preferred by the user. - -proc msgcat::mcpreferences {} { - variable Loclist - return $Loclist -} - -# msgcat::mcloadedlocales -- -# -# Get or change the list of currently loaded default locales -# -# The following subcommands are available: -# loaded -# Get the current list of loaded locales -# clear -# Remove all loaded locales not present in mcpreferences. -# -# Arguments: -# subcommand One of loaded or clear -# -# Results: -# Empty string, if not stated differently for the subcommand - -proc msgcat::mcloadedlocales {subcommand} { - variable Loclist - variable LoadedLocales - variable Msgs - variable PackageConfig - switch -exact -- $subcommand { - clear { - # Remove all locales not contained in Loclist - # skip any packages with package locale - set LoadedLocales $Loclist - foreach ns [dict keys $Msgs] { - if {![dict exists $PackageConfig loclist $ns]} { - foreach locale [dict keys [dict get $Msgs $ns]] { - if {$locale ni $Loclist} { - dict unset Msgs $ns $locale - } - } - } - } - } - loaded { return $LoadedLocales } - default { - return -code error "unknown subcommand \"$subcommand\": must be\ - clear, or loaded" - } - } - return -} - -# msgcat::mcpackagelocale -- -# -# Get or change the package locale of the calling package. -# -# The following subcommands are available: -# set -# Set a package locale. -# This may load message catalog files and may clear message catalog -# items, if the former locale was the default locale. -# Returns the normalized set locale. -# The default locale is taken, if locale is not given. -# get -# Get the locale valid for this package. -# isset -# Returns true, if a package locale is set -# unset -# Unset the package locale and activate the default locale. -# This loads message catalog file which where missing in the package -# locale. -# preferences -# Return locale preference list valid for the package. -# loaded -# Return loaded locale list valid for the current package. -# clear -# If the current package has a package locale, remove all package -# locales not containes in package mcpreferences. -# It is an error to call this without a package locale set. -# -# The subcommands get, preferences and loaded return the corresponding -# default data, if no package locale is set. -# -# Arguments: -# subcommand see list above -# locale package locale (only set subcommand) -# -# Results: -# Empty string, if not stated differently for the subcommand - -proc msgcat::mcpackagelocale {subcommand {locale ""}} { - # todo: implement using an ensemble - variable Loclist - variable LoadedLocales - variable Msgs - variable PackageConfig - # Check option - # check if required item is exactly provided - if {[llength [info level 0]] == 2} { - # locale not given - unset locale - } else { - # locale given - if {$subcommand in - {"get" "isset" "unset" "preferences" "loaded" "clear"} } { - return -code error "wrong # args: should be\ - \"[lrange [info level 0] 0 1]\"" - } - set locale [string tolower $locale] - } - set ns [uplevel 1 {::namespace current}] - - switch -exact -- $subcommand { - get { return [lindex [PackagePreferences $ns] 0] } - preferences { return [PackagePreferences $ns] } - loaded { return [PackageLocales $ns] } - present { return [expr {$locale in [PackageLocales $ns]} ]} - isset { return [dict exists $PackageConfig loclist $ns] } - set { # set a package locale or add a package locale - - # Copy the default locale if no package locale set so far - if {![dict exists $PackageConfig loclist $ns]} { - dict set PackageConfig loclist $ns $Loclist - dict set PackageConfig loadedlocales $ns $LoadedLocales - } - - # Check if changed - set loclist [dict get $PackageConfig loclist $ns] - if {! [info exists locale] || $locale eq [lindex $loclist 0] } { - return [lindex $loclist 0] - } - - # Change loclist - set loclist [GetPreferences $locale] - set locale [lindex $loclist 0] - dict set PackageConfig loclist $ns $loclist - - # load eventual missing locales - set loadedLocales [dict get $PackageConfig loadedlocales $ns] - if {$locale in $loadedLocales} { return $locale } - set loadLocales [ListComplement $loadedLocales $loclist] - dict set PackageConfig loadedlocales $ns\ - [concat $loadedLocales $loadLocales] - Load $ns $loadLocales - return $locale - } - clear { # Remove all locales not contained in Loclist - if {![dict exists $PackageConfig loclist $ns]} { - return -code error "clear only when package locale set" - } - set loclist [dict get $PackageConfig loclist $ns] - dict set PackageConfig loadedlocales $ns $loclist - if {[dict exists $Msgs $ns]} { - foreach locale [dict keys [dict get $Msgs $ns]] { - if {$locale ni $loclist} { - dict unset Msgs $ns $locale - } - } - } - } - unset { # unset package locale and restore default locales - - if { ![dict exists $PackageConfig loclist $ns] } { return } - - # unset package locale - set loadLocales [ListComplement\ - [dict get $PackageConfig loadedlocales $ns] $LoadedLocales] - dict unset PackageConfig loadedlocales $ns - dict unset PackageConfig loclist $ns - - # unset keys not in global loaded locales - if {[dict exists $Msgs $ns]} { - foreach locale [dict keys [dict get $Msgs $ns]] { - if {$locale ni $LoadedLocales} { - dict unset Msgs $ns $locale - } - } - } - - # Add missing locales - Load $ns $loadLocales - } - default { - return -code error "unknown subcommand \"$subcommand\": must be\ - clear, get, isset, loaded, present, set, or unset" - } - } - return -} - -# msgcat::mcforgetpackage -- -# -# Remove any data of the calling package from msgcat -# - -proc msgcat::mcforgetpackage {} { - # todo: this may be implemented using an ensemble - variable PackageConfig - variable Msgs - set ns [uplevel 1 {::namespace current}] - # Remove MC items - dict unset Msgs $ns - # Remove config items - foreach key [dict keys $PackageConfig] { - dict unset PackageConfig $key $ns - } - return -} - -# msgcat::mcpackageconfig -- -# -# Get or modify the per caller namespace (e.g. packages) config options. -# -# Available subcommands are: -# -# get get the current value or an error if not set. -# isset return true, if the option is set -# set set the value (see also distinct option). -# Returns the number of loaded message files. -# unset Clear option. return "". -# -# Available options are: -# -# mcfolder -# The message catalog folder of the package. -# This is automatically set by mcload. -# If the value is changed using the set subcommand, an evntual -# loadcmd is invoked and all message files of the package locale are -# loaded. -# -# loadcmd -# The command gets executed before a message file would be -# sourced for this module. -# The command is invoked with the expanded locale list to load. -# The command is not invoked if the registering package namespace -# is not present. -# This callback might also be used as an alternative to message -# files. -# If the value is changed using the set subcommand, the callback is -# directly invoked with the current file locale list. No file load is -# executed. -# -# changecmd -# The command is invoked, after an executed locale change. -# Appended argument is expanded mcpreferences. -# -# unknowncmd -# Use a package locale mcunknown procedure instead the global one. -# The appended arguments are identical to mcunknown. -# A default unknown handler is used if set to the empty string. -# This consists in returning the key if no arguments are given. -# With given arguments, format is used to process the arguments. -# -# Arguments: -# subcommand Operation on the package -# option The package option to get or set. -# ?value? Eventual value for the subcommand -# -# Results: -# Depends on the subcommand and option and is described there - -proc msgcat::mcpackageconfig {subcommand option {value ""}} { - variable PackageConfig - # get namespace - set ns [uplevel 1 {::namespace current}] - - if {$option ni {"mcfolder" "loadcmd" "changecmd" "unknowncmd"}} { - return -code error "bad option \"$option\": must be mcfolder, loadcmd,\ - changecmd, or unknowncmd" - } - - # check if value argument is exactly provided - if {[llength [info level 0]] == 4 } { - # value provided - if {$subcommand in {"get" "isset" "unset"}} { - return -code error "wrong # args: should be\ - \"[lrange [info level 0] 0 2] value\"" - } - } elseif {$subcommand eq "set"} { - return -code error\ - "wrong # args: should be \"[lrange [info level 0] 0 2]\"" - } - - # Execute subcommands - switch -exact -- $subcommand { - get { # Operation get return current value - if {![dict exists $PackageConfig $option $ns]} { - return -code error "package option \"$option\" not set" - } - return [dict get $PackageConfig $option $ns] - } - isset { return [dict exists $PackageConfig $option $ns] } - unset { dict unset PackageConfig $option $ns } - set { # Set option - - if {$option eq "mcfolder"} { - set value [file normalize $value] - } - # Check if changed - if { [dict exists $PackageConfig $option $ns] - && $value eq [dict get $PackageConfig $option $ns] } { - return 0 - } - - # set new value - dict set PackageConfig $option $ns $value - - # Reload pending message catalogs - switch -exact -- $option { - mcfolder { return [Load $ns [PackageLocales $ns]] } - loadcmd { return [Load $ns [PackageLocales $ns] 1] } - } - return 0 - } - default { - return -code error "unknown subcommand \"$subcommand\":\ - must be get, isset, set, or unset" - } - } - return -} - -# msgcat::PackagePreferences -- -# -# Return eventual present package preferences or the default list if not -# present. -# -# Arguments: -# ns Package namespace -# -# Results: -# locale list - -proc msgcat::PackagePreferences {ns} { - variable PackageConfig - if {[dict exists $PackageConfig loclist $ns]} { - return [dict get $PackageConfig loclist $ns] - } - variable Loclist - return $Loclist -} - -# msgcat::PackageLocales -- -# -# Return eventual present package locales or the default list if not -# present. -# -# Arguments: -# ns Package namespace -# -# Results: -# locale list - -proc msgcat::PackageLocales {ns} { - variable PackageConfig - if {[dict exists $PackageConfig loadedlocales $ns]} { - return [dict get $PackageConfig loadedlocales $ns] - } - variable LoadedLocales - return $LoadedLocales -} - -# msgcat::ListComplement -- -# -# Build the complement of two lists. -# Return a list with all elements in list2 but not in list1. -# Optionally return the intersection. -# -# Arguments: -# list1 excluded list -# list2 included list -# inlistname If not "", write in this variable the intersection list -# -# Results: -# list with all elements in list2 but not in list1 - -proc msgcat::ListComplement {list1 list2 {inlistname ""}} { - if {"" ne $inlistname} { - upvar 1 $inlistname inlist - } - set inlist {} - set outlist {} - foreach item $list2 { - if {$item in $list1} { - lappend inlist $item - } else { - lappend outlist $item - } - } - return $outlist -} - -# msgcat::mcload -- -# -# Attempt to load message catalogs for each locale in the -# preference list from the specified directory. -# -# Arguments: -# langdir The directory to search. -# -# Results: -# Returns the number of message catalogs that were loaded. - -proc msgcat::mcload {langdir} { - return [uplevel 1 [list\ - [namespace origin mcpackageconfig] set mcfolder $langdir]] -} - -# msgcat::LoadAll -- -# -# Load a list of locales for all packages not having a package locale -# list. -# -# Arguments: -# langdir The directory to search. -# -# Results: -# Returns the number of message catalogs that were loaded. - -proc msgcat::LoadAll {locales} { - variable PackageConfig - variable LoadedLocales - if {0 == [llength $locales]} { return {} } - # filter jet unloaded locales - set locales [ListComplement $LoadedLocales $locales] - if {0 == [llength $locales]} { return {} } - lappend LoadedLocales {*}$locales - - set packages [lsort -unique [concat\ - [dict keys [dict get $PackageConfig loadcmd]]\ - [dict keys [dict get $PackageConfig mcfolder]]]] - foreach ns $packages { - if {! [dict exists $PackageConfig loclist $ns] } { - Load $ns $locales - } - } - return $locales -} - -# msgcat::Load -- -# -# Invoke message load callback and load message catalog files. -# -# Arguments: -# ns Namespace (equal package) to load the message catalog. -# locales List of locales to load. -# callbackonly true if only callback should be invoked -# -# Results: -# Returns the number of message catalogs that were loaded. - -proc msgcat::Load {ns locales {callbackonly 0}} { - variable FileLocale - variable PackageConfig - variable LoadedLocals - - if {0 == [llength $locales]} { return 0 } - - # Invoke callback - Invoke loadcmd $locales $ns - - if {$callbackonly || ![dict exists $PackageConfig mcfolder $ns]} { - return 0 - } - - # Invoke file load - set langdir [dict get $PackageConfig mcfolder $ns] - - # Save the file locale if we are recursively called - if {[info exists FileLocale]} { - set nestedFileLocale $FileLocale - } - set x 0 - foreach p $locales { - if {$p eq {}} { - set p ROOT - } - set langfile [file join $langdir $p.msg] - if {[file exists $langfile]} { - incr x - set FileLocale [string tolower\ - [file tail [file rootname $langfile]]] - if {"root" eq $FileLocale} { - set FileLocale "" - } - namespace inscope $ns [list ::source -encoding utf-8 $langfile] - unset FileLocale - } - } - if {[info exists nestedFileLocale]} { - set FileLocale $nestedFileLocale - } - return $x -} - -# msgcat::Invoke -- -# -# Invoke a set of registered callbacks. -# The callback is only invoked, if its registered namespace exists. -# -# Arguments: -# index Index into PackageConfig to get callback command -# arglist parameters to the callback invocation -# ns (Optional) package to call. -# If not given or empty, check all registered packages. -# resultname Variable to save the callback result of the last called -# callback to. May be set to "" to discard the result. -# failerror (0) Fail on error if true. Otherwise call bgerror. -# -# Results: -# Possible values: -# - 0: no valid command registered -# - 1: registered command was the empty string -# - 2: registered command called, resultname is set -# - 3: registered command failed -# If multiple commands are called, the maximum of all results is returned. - -proc msgcat::Invoke {index arglist {ns ""} {resultname ""} {failerror 0}} { - variable PackageConfig - variable Config - if {"" ne $resultname} { - upvar 1 $resultname result - } - if {"" eq $ns} { - set packageList [dict keys [dict get $PackageConfig $index]] - } else { - set packageList [list $ns] - } - set ret 0 - foreach ns $packageList { - if {[dict exists $PackageConfig $index $ns] && [namespace exists $ns]} { - set cmd [dict get $PackageConfig $index $ns] - if {"" eq $cmd} { - if {$ret == 0} {set ret 1} - } else { - if {$failerror} { - set result [namespace inscope $ns $cmd {*}$arglist] - set ret 2 - } elseif {1 == [catch { - set result [namespace inscope $ns $cmd {*}$arglist] - if {$ret < 2} {set ret 2} - } err derr]} { - after idle [concat [::interp bgerror ""]\ - [list $err $derr]] - set ret 3 - } - } - } - } - return $ret -} - -# msgcat::mcset -- -# -# Set the translation for a given string in a specified locale. -# -# Arguments: -# locale The locale to use. -# src The source string. -# dest (Optional) The translated string. If omitted, -# the source string is used. -# -# Results: -# Returns the new locale. - -proc msgcat::mcset {locale src {dest ""}} { - variable Msgs - if {[llength [info level 0]] == 3} { ;# dest not specified - set dest $src - } - - set ns [uplevel 1 [list ::namespace current]] - - set locale [string tolower $locale] - - dict set Msgs $ns $locale $src $dest - return $dest -} - -# msgcat::mcflset -- -# -# Set the translation for a given string in the current file locale. -# -# Arguments: -# src The source string. -# dest (Optional) The translated string. If omitted, -# the source string is used. -# -# Results: -# Returns the new locale. - -proc msgcat::mcflset {src {dest ""}} { - variable FileLocale - variable Msgs - - if {![info exists FileLocale]} { - return -code error "must only be used inside a message catalog loaded\ - with ::msgcat::mcload" - } - return [uplevel 1 [list [namespace origin mcset] $FileLocale $src $dest]] -} - -# msgcat::mcmset -- -# -# Set the translation for multiple strings in a specified locale. -# -# Arguments: -# locale The locale to use. -# pairs One or more src/dest pairs (must be even length) -# -# Results: -# Returns the number of pairs processed - -proc msgcat::mcmset {locale pairs} { - variable Msgs - - set length [llength $pairs] - if {$length % 2} { - return -code error "bad translation list:\ - should be \"[lindex [info level 0] 0] locale {src dest ...}\"" - } - - set locale [string tolower $locale] - set ns [uplevel 1 [list ::namespace current]] - - foreach {src dest} $pairs { - dict set Msgs $ns $locale $src $dest - } - - return [expr {$length / 2}] -} - -# msgcat::mcflmset -- -# -# Set the translation for multiple strings in the mc file locale. -# -# Arguments: -# pairs One or more src/dest pairs (must be even length) -# -# Results: -# Returns the number of pairs processed - -proc msgcat::mcflmset {pairs} { - variable FileLocale - variable Msgs - - if {![info exists FileLocale]} { - return -code error "must only be used inside a message catalog loaded\ - with ::msgcat::mcload" - } - return [uplevel 1 [list [namespace origin mcmset] $FileLocale $pairs]] -} - -# msgcat::mcunknown -- -# -# This routine is called by msgcat::mc if a translation cannot -# be found for a string and no unknowncmd is set for the current -# package. This routine is intended to be replaced -# by an application specific routine for error reporting -# purposes. The default behavior is to return the source string. -# If additional args are specified, the format command will be used -# to work them into the traslated string. -# -# Arguments: -# locale The current locale. -# src The string to be translated. -# args Args to pass to the format command -# -# Results: -# Returns the translated value. - -proc msgcat::mcunknown {args} { - return [uplevel 1 [list [namespace origin DefaultUnknown] {*}$args]] -} - -# msgcat::DefaultUnknown -- -# -# This routine is called by msgcat::mc if a translation cannot -# be found for a string in the following circumstances: -# - Default global handler, if mcunknown is not redefined. -# - Per package handler, if the package sets unknowncmd to the empty -# string. -# It returna the source string if the argument list is empty. -# If additional args are specified, the format command will be used -# to work them into the traslated string. -# -# Arguments: -# locale (unused) The current locale. -# src The string to be translated. -# args Args to pass to the format command -# -# Results: -# Returns the translated value. - -proc msgcat::DefaultUnknown {locale src args} { - if {[llength $args]} { - return [format $src {*}$args] - } else { - return $src - } -} - -# msgcat::mcmax -- -# -# Calculates the maximum length of the translated strings of the given -# list. -# -# Arguments: -# args strings to translate. -# -# Results: -# Returns the length of the longest translated string. - -proc msgcat::mcmax {args} { - set max 0 - foreach string $args { - set translated [uplevel 1 [list [namespace origin mc] $string]] - set len [string length $translated] - if {$len>$max} { - set max $len - } - } - return $max -} - -# Convert the locale values stored in environment variables to a form -# suitable for passing to [mclocale] -proc msgcat::ConvertLocale {value} { - # Assume $value is of form: $language[_$territory][.$codeset][@modifier] - # Convert to form: $language[_$territory][_$modifier] - # - # Comment out expanded RE version -- bugs alleged - # regexp -expanded { - # ^ # Match all the way to the beginning - # ([^_.@]*) # Match "lanugage"; ends with _, ., or @ - # (_([^.@]*))? # Match (optional) "territory"; starts with _ - # ([.]([^@]*))? # Match (optional) "codeset"; starts with . - # (@(.*))? # Match (optional) "modifier"; starts with @ - # $ # Match all the way to the end - # } $value -> language _ territory _ codeset _ modifier - if {![regexp {^([^_.@]+)(_([^.@]*))?([.]([^@]*))?(@(.*))?$} $value \ - -> language _ territory _ codeset _ modifier]} { - return -code error "invalid locale '$value': empty language part" - } - set ret $language - if {[string length $territory]} { - append ret _$territory - } - if {[string length $modifier]} { - append ret _$modifier - } - return $ret -} - -# Initialize the default locale -proc msgcat::Init {} { - global env - - # - # set default locale, try to get from environment - # - foreach varName {LC_ALL LC_MESSAGES LANG} { - if {[info exists env($varName)] && ("" ne $env($varName))} { - if {![catch { - mclocale [ConvertLocale $env($varName)] - }]} { - return - } - } - } - # - # On Darwin, fallback to current CFLocale identifier if available. - # - if {[info exists ::tcl::mac::locale] && $::tcl::mac::locale ne ""} { - if {![catch { - mclocale [ConvertLocale $::tcl::mac::locale] - }]} { - return - } - } - # - # The rest of this routine is special processing for Windows or - # Cygwin. All other platforms, get out now. - # - if {([info sharedlibextension] ne ".dll") - || [catch {package require registry}]} { - mclocale C - return - } - # - # On Windows or Cygwin, try to set locale depending on registry - # settings, or fall back on locale of "C". - # - - # On Vista and later: - # HCU/Control Panel/Desktop : PreferredUILanguages is for language packs, - # HCU/Control Pannel/International : localName is the default locale. - # - # They contain the local string as RFC5646, composed of: - # [a-z]{2,3} : language - # -[a-z]{4} : script (optional, translated by table Latn->latin) - # -[a-z]{2}|[0-9]{3} : territory (optional, numerical region codes not used) - # (-.*)* : variant, extension, private use (optional, not used) - # Those are translated to local strings. - # Examples: de-CH -> de_ch, sr-Latn-CS -> sr_cs@latin, es-419 -> es - # - foreach key {{HKEY_CURRENT_USER\Control Panel\Desktop} {HKEY_CURRENT_USER\Control Panel\International}}\ - value {PreferredUILanguages localeName} { - if {![catch {registry get $key $value} localeName] - && [regexp {^([a-z]{2,3})(?:-([a-z]{4}))?(?:-([a-z]{2}))?(?:-.+)?$}\ - [string tolower $localeName] match locale script territory]} { - if {"" ne $territory} { - append locale _ $territory - } - set modifierDict [dict create latn latin cyrl cyrillic] - if {[dict exists $modifierDict $script]} { - append locale @ [dict get $modifierDict $script] - } - if {![catch {mclocale [ConvertLocale $locale]}]} { - return - } - } - } - - # then check value locale which contains a numerical language ID - if {[catch { - set locale [registry get $key "locale"] - }]} { - mclocale C - return - } - # - # Keep trying to match against smaller and smaller suffixes - # of the registry value, since the latter hexadigits appear - # to determine general language and earlier hexadigits determine - # more precise information, such as territory. For example, - # 0409 - English - United States - # 0809 - English - United Kingdom - # Add more translations to the WinRegToISO639 array above. - # - variable WinRegToISO639 - set locale [string tolower $locale] - while {[string length $locale]} { - if {![catch { - mclocale [ConvertLocale [dict get $WinRegToISO639 $locale]] - }]} { - return - } - set locale [string range $locale 1 end] - } - # - # No translation known. Fall back on "C" locale - # - mclocale C -} -msgcat::Init diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8/8.5/tcltest-2.4.1.tm b/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8/8.5/tcltest-2.4.1.tm @@ -1,3420 +0,0 @@ -# tcltest.tcl -- -# -# This file contains support code for the Tcl test suite. It -# defines the tcltest namespace and finds and defines the output -# directory, constraints available, output and error channels, -# etc. used by Tcl tests. See the tcltest man page for more -# details. -# -# This design was based on the Tcl testing approach designed and -# initially implemented by Mary Ann May-Pumphrey of Sun -# Microsystems. -# -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2000 by Ajuba Solutions -# Contributions from Don Porter, NIST, 2002. (not subject to US copyright) -# All rights reserved. - -package require Tcl 8.5- ;# -verbose line uses [info frame] -namespace eval tcltest { - - # When the version number changes, be sure to update the pkgIndex.tcl file, - # and the install directory in the Makefiles. When the minor version - # changes (new feature) be sure to update the man page as well. - variable Version 2.4.1 - - # Compatibility support for dumb variables defined in tcltest 1 - # Do not use these. Call [package provide Tcl] and [info patchlevel] - # yourself. You don't need tcltest to wrap it for you. - variable version [package provide Tcl] - variable patchLevel [info patchlevel] - -##### Export the public tcltest procs; several categories - # - # Export the main functional commands that do useful things - namespace export cleanupTests loadTestedCommands makeDirectory \ - makeFile removeDirectory removeFile runAllTests test - - # Export configuration commands that control the functional commands - namespace export configure customMatch errorChannel interpreter \ - outputChannel testConstraint - - # Export commands that are duplication (candidates for deprecation) - namespace export bytestring ;# dups [encoding convertfrom identity] - namespace export debug ;# [configure -debug] - namespace export errorFile ;# [configure -errfile] - namespace export limitConstraints ;# [configure -limitconstraints] - namespace export loadFile ;# [configure -loadfile] - namespace export loadScript ;# [configure -load] - namespace export match ;# [configure -match] - namespace export matchFiles ;# [configure -file] - namespace export matchDirectories ;# [configure -relateddir] - namespace export normalizeMsg ;# application of [customMatch] - namespace export normalizePath ;# [file normalize] (8.4) - namespace export outputFile ;# [configure -outfile] - namespace export preserveCore ;# [configure -preservecore] - namespace export singleProcess ;# [configure -singleproc] - namespace export skip ;# [configure -skip] - namespace export skipFiles ;# [configure -notfile] - namespace export skipDirectories ;# [configure -asidefromdir] - namespace export temporaryDirectory ;# [configure -tmpdir] - namespace export testsDirectory ;# [configure -testdir] - namespace export verbose ;# [configure -verbose] - namespace export viewFile ;# binary encoding [read] - namespace export workingDirectory ;# [cd] [pwd] - - # Export deprecated commands for tcltest 1 compatibility - namespace export getMatchingFiles mainThread restoreState saveState \ - threadReap - - # tcltest::normalizePath -- - # - # This procedure resolves any symlinks in the path thus creating - # a path without internal redirection. It assumes that the - # incoming path is absolute. - # - # Arguments - # pathVar - name of variable containing path to modify. - # - # Results - # The path is modified in place. - # - # Side Effects: - # None. - # - proc normalizePath {pathVar} { - upvar 1 $pathVar path - set oldpwd [pwd] - catch {cd $path} - set path [pwd] - cd $oldpwd - return $path - } - -##### Verification commands used to test values of variables and options - # - # Verification command that accepts everything - proc AcceptAll {value} { - return $value - } - - # Verification command that accepts valid Tcl lists - proc AcceptList { list } { - return [lrange $list 0 end] - } - - # Verification command that accepts a glob pattern - proc AcceptPattern { pattern } { - return [AcceptAll $pattern] - } - - # Verification command that accepts integers - proc AcceptInteger { level } { - return [incr level 0] - } - - # Verification command that accepts boolean values - proc AcceptBoolean { boolean } { - return [expr {$boolean && $boolean}] - } - - # Verification command that accepts (syntactically) valid Tcl scripts - proc AcceptScript { script } { - if {![info complete $script]} { - return -code error "invalid Tcl script: $script" - } - return $script - } - - # Verification command that accepts (converts to) absolute pathnames - proc AcceptAbsolutePath { path } { - return [file join [pwd] $path] - } - - # Verification command that accepts existing readable directories - proc AcceptReadable { path } { - if {![file readable $path]} { - return -code error "\"$path\" is not readable" - } - return $path - } - proc AcceptDirectory { directory } { - set directory [AcceptAbsolutePath $directory] - if {![file exists $directory]} { - return -code error "\"$directory\" does not exist" - } - if {![file isdir $directory]} { - return -code error "\"$directory\" is not a directory" - } - return [AcceptReadable $directory] - } - -##### Initialize internal arrays of tcltest, but only if the caller - # has not already pre-initialized them. This is done to support - # compatibility with older tests that directly access internals - # rather than go through command interfaces. - # - proc ArrayDefault {varName value} { - variable $varName - if {[array exists $varName]} { - return - } - if {[info exists $varName]} { - # Pre-initialized value is a scalar: destroy it! - unset $varName - } - array set $varName $value - } - - # save the original environment so that it can be restored later - ArrayDefault originalEnv [array get ::env] - - # initialize numTests array to keep track of the number of tests - # that pass, fail, and are skipped. - ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0] - - # createdNewFiles will store test files as indices and the list of - # files (that should not have been) left behind by the test files - # as values. - ArrayDefault createdNewFiles {} - - # initialize skippedBecause array to keep track of constraints that - # kept tests from running; a constraint name of "userSpecifiedSkip" - # means that the test appeared on the list of tests that matched the - # -skip value given to the flag; "userSpecifiedNonMatch" means that - # the test didn't match the argument given to the -match flag; both - # of these constraints are counted only if tcltest::debug is set to - # true. - ArrayDefault skippedBecause {} - - # initialize the testConstraints array to keep track of valid - # predefined constraints (see the explanation for the - # InitConstraints proc for more details). - ArrayDefault testConstraints {} - -##### Initialize internal variables of tcltest, but only if the caller - # has not already pre-initialized them. This is done to support - # compatibility with older tests that directly access internals - # rather than go through command interfaces. - # - proc Default {varName value {verify AcceptAll}} { - variable $varName - if {![info exists $varName]} { - variable $varName [$verify $value] - } else { - variable $varName [$verify [set $varName]] - } - } - - # Save any arguments that we might want to pass through to other - # programs. This is used by the -args flag. - # FINDUSER - Default parameters {} - - # Count the number of files tested (0 if runAllTests wasn't called). - # runAllTests will set testSingleFile to false, so stats will - # not be printed until runAllTests calls the cleanupTests proc. - # The currentFailure var stores the boolean value of whether the - # current test file has had any failures. The failFiles list - # stores the names of test files that had failures. - Default numTestFiles 0 AcceptInteger - Default testSingleFile true AcceptBoolean - Default currentFailure false AcceptBoolean - Default failFiles {} AcceptList - - # Tests should remove all files they create. The test suite will - # check the current working dir for files created by the tests. - # filesMade keeps track of such files created using the makeFile and - # makeDirectory procedures. filesExisted stores the names of - # pre-existing files. - # - # Note that $filesExisted lists only those files that exist in - # the original [temporaryDirectory]. - Default filesMade {} AcceptList - Default filesExisted {} AcceptList - proc FillFilesExisted {} { - variable filesExisted - - # Save the names of files that already exist in the scratch directory. - foreach file [glob -nocomplain -directory [temporaryDirectory] *] { - lappend filesExisted [file tail $file] - } - - # After successful filling, turn this into a no-op. - proc FillFilesExisted args {} - } - - # Kept only for compatibility - Default constraintsSpecified {} AcceptList - trace add variable constraintsSpecified read [namespace code { - set constraintsSpecified [array names testConstraints] ;#}] - - # tests that use threads need to know which is the main thread - Default mainThread 1 - variable mainThread - if {[info commands thread::id] ne {}} { - set mainThread [thread::id] - } elseif {[info commands testthread] ne {}} { - set mainThread [testthread id] - } - - # Set workingDirectory to [pwd]. The default output directory for - # Tcl tests is the working directory. Whenever this value changes - # change to that directory. - variable workingDirectory - trace add variable workingDirectory write \ - [namespace code {cd $workingDirectory ;#}] - - Default workingDirectory [pwd] AcceptAbsolutePath - proc workingDirectory { {dir ""} } { - variable workingDirectory - if {[llength [info level 0]] == 1} { - return $workingDirectory - } - set workingDirectory [AcceptAbsolutePath $dir] - } - - # Set the location of the execuatble - Default tcltest [info nameofexecutable] - trace add variable tcltest write [namespace code {testConstraint stdio \ - [eval [ConstraintInitializer stdio]] ;#}] - - # save the platform information so it can be restored later - Default originalTclPlatform [array get ::tcl_platform] - - # If a core file exists, save its modification time. - if {[file exists [file join [workingDirectory] core]]} { - Default coreModTime \ - [file mtime [file join [workingDirectory] core]] - } - - # stdout and stderr buffers for use when we want to store them - Default outData {} - Default errData {} - - # keep track of test level for nested test commands - variable testLevel 0 - - # the variables and procs that existed when saveState was called are - # stored in a variable of the same name - Default saveState {} - - # Internationalization support -- used in [SetIso8859_1_Locale] and - # [RestoreLocale]. Those commands are used in cmdIL.test. - - if {![info exists [namespace current]::isoLocale]} { - variable isoLocale fr - switch -- $::tcl_platform(platform) { - "unix" { - - # Try some 'known' values for some platforms: - - switch -exact -- $::tcl_platform(os) { - "FreeBSD" { - set isoLocale fr_FR.ISO_8859-1 - } - HP-UX { - set isoLocale fr_FR.iso88591 - } - Linux - - IRIX { - set isoLocale fr - } - default { - - # Works on SunOS 4 and Solaris, and maybe - # others... Define it to something else on your - # system if you want to test those. - - set isoLocale iso_8859_1 - } - } - } - "windows" { - set isoLocale French - } - } - } - - variable ChannelsWeOpened; array set ChannelsWeOpened {} - # output goes to stdout by default - Default outputChannel stdout - proc outputChannel { {filename ""} } { - variable outputChannel - variable ChannelsWeOpened - - # This is very subtle and tricky, so let me try to explain. - # (Hopefully this longer comment will be clear when I come - # back in a few months, unlike its predecessor :) ) - # - # The [outputChannel] command (and underlying variable) have to - # be kept in sync with the [configure -outfile] configuration - # option ( and underlying variable Option(-outfile) ). This is - # accomplished with a write trace on Option(-outfile) that will - # update [outputChannel] whenver a new value is written. That - # much is easy. - # - # The trick is that in order to maintain compatibility with - # version 1 of tcltest, we must allow every configuration option - # to get its inital value from command line arguments. This is - # accomplished by setting initial read traces on all the - # configuration options to parse the command line option the first - # time they are read. These traces are cancelled whenever the - # program itself calls [configure]. - # - # OK, then so to support tcltest 1 compatibility, it seems we want - # to get the return from [outputFile] to trigger the read traces, - # just in case. - # - # BUT! A little known feature of Tcl variable traces is that - # traces are disabled during the handling of other traces. So, - # if we trigger read traces on Option(-outfile) and that triggers - # command line parsing which turns around and sets an initial - # value for Option(-outfile) -- <whew!> -- the write trace that - # would keep [outputChannel] in sync with that new initial value - # would not fire! - # - # SO, finally, as a workaround, instead of triggering read traces - # by invoking [outputFile], we instead trigger the same set of - # read traces by invoking [debug]. Any command that reads a - # configuration option would do. [debug] is just a handy one. - # The end result is that we support tcltest 1 compatibility and - # keep outputChannel and -outfile in sync in all cases. - debug - - if {[llength [info level 0]] == 1} { - return $outputChannel - } - if {[info exists ChannelsWeOpened($outputChannel)]} { - close $outputChannel - unset ChannelsWeOpened($outputChannel) - } - switch -exact -- $filename { - stderr - - stdout { - set outputChannel $filename - } - default { - set outputChannel [open $filename a] - set ChannelsWeOpened($outputChannel) 1 - - # If we created the file in [temporaryDirectory], then - # [cleanupTests] will delete it, unless we claim it was - # already there. - set outdir [normalizePath [file dirname \ - [file join [pwd] $filename]]] - if {$outdir eq [temporaryDirectory]} { - variable filesExisted - FillFilesExisted - set filename [file tail $filename] - if {$filename ni $filesExisted} { - lappend filesExisted $filename - } - } - } - } - return $outputChannel - } - - # errors go to stderr by default - Default errorChannel stderr - proc errorChannel { {filename ""} } { - variable errorChannel - variable ChannelsWeOpened - - # This is subtle and tricky. See the comment above in - # [outputChannel] for a detailed explanation. - debug - - if {[llength [info level 0]] == 1} { - return $errorChannel - } - if {[info exists ChannelsWeOpened($errorChannel)]} { - close $errorChannel - unset ChannelsWeOpened($errorChannel) - } - switch -exact -- $filename { - stderr - - stdout { - set errorChannel $filename - } - default { - set errorChannel [open $filename a] - set ChannelsWeOpened($errorChannel) 1 - - # If we created the file in [temporaryDirectory], then - # [cleanupTests] will delete it, unless we claim it was - # already there. - set outdir [normalizePath [file dirname \ - [file join [pwd] $filename]]] - if {$outdir eq [temporaryDirectory]} { - variable filesExisted - FillFilesExisted - set filename [file tail $filename] - if {$filename ni $filesExisted} { - lappend filesExisted $filename - } - } - } - } - return $errorChannel - } - -##### Set up the configurable options - # - # The configurable options of the package - variable Option; array set Option {} - - # Usage strings for those options - variable Usage; array set Usage {} - - # Verification commands for those options - variable Verify; array set Verify {} - - # Initialize the default values of the configurable options that are - # historically associated with an exported variable. If that variable - # is already set, support compatibility by accepting its pre-set value. - # Use [trace] to establish ongoing connection between the deprecated - # exported variable and the modern option kept as a true internal var. - # Also set up usage string and value testing for the option. - proc Option {option value usage {verify AcceptAll} {varName {}}} { - variable Option - variable Verify - variable Usage - variable OptionControlledVariables - variable DefaultValue - set Usage($option) $usage - set Verify($option) $verify - set DefaultValue($option) $value - if {[catch {$verify $value} msg]} { - return -code error $msg - } else { - set Option($option) $msg - } - if {[string length $varName]} { - variable $varName - if {[info exists $varName]} { - if {[catch {$verify [set $varName]} msg]} { - return -code error $msg - } else { - set Option($option) $msg - } - unset $varName - } - namespace eval [namespace current] \ - [list upvar 0 Option($option) $varName] - # Workaround for Bug (now Feature Request) 572889. Grrrr.... - # Track all the variables tied to options - lappend OptionControlledVariables $varName - # Later, set auto-configure read traces on all - # of them, since a single trace on Option does not work. - proc $varName {{value {}}} [subst -nocommands { - if {[llength [info level 0]] == 2} { - Configure $option [set value] - } - return [Configure $option] - }] - } - } - - proc MatchingOption {option} { - variable Option - set match [array names Option $option*] - switch -- [llength $match] { - 0 { - set sorted [lsort [array names Option]] - set values [join [lrange $sorted 0 end-1] ", "] - append values ", or [lindex $sorted end]" - return -code error "unknown option $option: should be\ - one of $values" - } - 1 { - return [lindex $match 0] - } - default { - # Exact match trumps ambiguity - if {$option in $match} { - return $option - } - set values [join [lrange $match 0 end-1] ", "] - append values ", or [lindex $match end]" - return -code error "ambiguous option $option:\ - could match $values" - } - } - } - - proc EstablishAutoConfigureTraces {} { - variable OptionControlledVariables - foreach varName [concat $OptionControlledVariables Option] { - variable $varName - trace add variable $varName read [namespace code { - ProcessCmdLineArgs ;#}] - } - } - - proc RemoveAutoConfigureTraces {} { - variable OptionControlledVariables - foreach varName [concat $OptionControlledVariables Option] { - variable $varName - foreach pair [trace info variable $varName] { - lassign $pair op cmd - if {($op eq "read") && - [string match *ProcessCmdLineArgs* $cmd]} { - trace remove variable $varName $op $cmd - } - } - } - # Once the traces are removed, this can become a no-op - proc RemoveAutoConfigureTraces {} {} - } - - proc Configure args { - variable Option - variable Verify - set n [llength $args] - if {$n == 0} { - return [lsort [array names Option]] - } - if {$n == 1} { - if {[catch {MatchingOption [lindex $args 0]} option]} { - return -code error $option - } - return $Option($option) - } - while {[llength $args] > 1} { - if {[catch {MatchingOption [lindex $args 0]} option]} { - return -code error $option - } - if {[catch {$Verify($option) [lindex $args 1]} value]} { - return -code error "invalid $option\ - value \"[lindex $args 1]\": $value" - } - set Option($option) $value - set args [lrange $args 2 end] - } - if {[llength $args]} { - if {[catch {MatchingOption [lindex $args 0]} option]} { - return -code error $option - } - return -code error "missing value for option $option" - } - } - proc configure args { - if {[llength $args] > 1} { - RemoveAutoConfigureTraces - } - set code [catch {Configure {*}$args} msg] - return -code $code $msg - } - - proc AcceptVerbose { level } { - set level [AcceptList $level] - set levelMap { - l list - p pass - b body - s skip - t start - e error - l line - m msec - u usec - } - set levelRegexp "^([join [dict values $levelMap] |])\$" - if {[llength $level] == 1} { - if {![regexp $levelRegexp $level]} { - # translate single characters abbreviations to expanded list - set level [string map $levelMap [split $level {}]] - } - } - set valid [list] - foreach v $level { - if {[regexp $levelRegexp $v]} { - lappend valid $v - } - } - return $valid - } - - proc IsVerbose {level} { - variable Option - return [expr {[lsearch -exact $Option(-verbose) $level] != -1}] - } - - # Default verbosity is to show bodies of failed tests - Option -verbose {body error} { - Takes any combination of the values 'p', 's', 'b', 't', 'e' and 'l'. - Test suite will display all passed tests if 'p' is specified, all - skipped tests if 's' is specified, the bodies of failed tests if - 'b' is specified, and when tests start if 't' is specified. - ErrorInfo is displayed if 'e' is specified. Source file line - information of failed tests is displayed if 'l' is specified. - } AcceptVerbose verbose - - # Match and skip patterns default to the empty list, except for - # matchFiles, which defaults to all .test files in the - # testsDirectory and matchDirectories, which defaults to all - # directories. - Option -match * { - Run all tests within the specified files that match one of the - list of glob patterns given. - } AcceptList match - - Option -skip {} { - Skip all tests within the specified tests (via -match) and files - that match one of the list of glob patterns given. - } AcceptList skip - - Option -file *.test { - Run tests in all test files that match the glob pattern given. - } AcceptPattern matchFiles - - # By default, skip files that appear to be SCCS lock files. - Option -notfile l.*.test { - Skip all test files that match the glob pattern given. - } AcceptPattern skipFiles - - Option -relateddir * { - Run tests in directories that match the glob pattern given. - } AcceptPattern matchDirectories - - Option -asidefromdir {} { - Skip tests in directories that match the glob pattern given. - } AcceptPattern skipDirectories - - # By default, don't save core files - Option -preservecore 0 { - If 2, save any core files produced during testing in the directory - specified by -tmpdir. If 1, notify the user if core files are - created. - } AcceptInteger preserveCore - - # debug output doesn't get printed by default; debug level 1 spits - # up only the tests that were skipped because they didn't match or - # were specifically skipped. A debug level of 2 would spit up the - # tcltest variables and flags provided; a debug level of 3 causes - # some additional output regarding operations of the test harness. - # The tcltest package currently implements only up to debug level 3. - Option -debug 0 { - Internal debug level - } AcceptInteger debug - - proc SetSelectedConstraints args { - variable Option - foreach c $Option(-constraints) { - testConstraint $c 1 - } - } - Option -constraints {} { - Do not skip the listed constraints listed in -constraints. - } AcceptList - trace add variable Option(-constraints) write \ - [namespace code {SetSelectedConstraints ;#}] - - # Don't run only the "-constraint" specified tests by default - proc ClearUnselectedConstraints args { - variable Option - variable testConstraints - if {!$Option(-limitconstraints)} {return} - foreach c [array names testConstraints] { - if {$c ni $Option(-constraints)} { - testConstraint $c 0 - } - } - } - Option -limitconstraints 0 { - whether to run only tests with the constraints - } AcceptBoolean limitConstraints - trace add variable Option(-limitconstraints) write \ - [namespace code {ClearUnselectedConstraints ;#}] - - # A test application has to know how to load the tested commands - # into the interpreter. - Option -load {} { - Specifies the script to load the tested commands. - } AcceptScript loadScript - - # Default is to run each test file in a separate process - Option -singleproc 0 { - whether to run all tests in one process - } AcceptBoolean singleProcess - - proc AcceptTemporaryDirectory { directory } { - set directory [AcceptAbsolutePath $directory] - if {![file exists $directory]} { - file mkdir $directory - } - set directory [AcceptDirectory $directory] - if {![file writable $directory]} { - if {[workingDirectory] eq $directory} { - # Special exception: accept the default value - # even if the directory is not writable - return $directory - } - return -code error "\"$directory\" is not writeable" - } - return $directory - } - - # Directory where files should be created - Option -tmpdir [workingDirectory] { - Save temporary files in the specified directory. - } AcceptTemporaryDirectory temporaryDirectory - trace add variable Option(-tmpdir) write \ - [namespace code {normalizePath Option(-tmpdir) ;#}] - - # Tests should not rely on the current working directory. - # Files that are part of the test suite should be accessed relative - # to [testsDirectory] - Option -testdir [workingDirectory] { - Search tests in the specified directory. - } AcceptDirectory testsDirectory - trace add variable Option(-testdir) write \ - [namespace code {normalizePath Option(-testdir) ;#}] - - proc AcceptLoadFile { file } { - if {$file eq {}} {return $file} - set file [file join [temporaryDirectory] $file] - return [AcceptReadable $file] - } - proc ReadLoadScript {args} { - variable Option - if {$Option(-loadfile) eq {}} {return} - set tmp [open $Option(-loadfile) r] - loadScript [read $tmp] - close $tmp - } - Option -loadfile {} { - Read the script to load the tested commands from the specified file. - } AcceptLoadFile loadFile - trace add variable Option(-loadfile) write [namespace code ReadLoadScript] - - proc AcceptOutFile { file } { - if {[string equal stderr $file]} {return $file} - if {[string equal stdout $file]} {return $file} - return [file join [temporaryDirectory] $file] - } - - # output goes to stdout by default - Option -outfile stdout { - Send output from test runs to the specified file. - } AcceptOutFile outputFile - trace add variable Option(-outfile) write \ - [namespace code {outputChannel $Option(-outfile) ;#}] - - # errors go to stderr by default - Option -errfile stderr { - Send errors from test runs to the specified file. - } AcceptOutFile errorFile - trace add variable Option(-errfile) write \ - [namespace code {errorChannel $Option(-errfile) ;#}] - - proc loadIntoSlaveInterpreter {slave args} { - variable Version - interp eval $slave [package ifneeded tcltest $Version] - interp eval $slave "tcltest::configure {*}{$args}" - interp alias $slave ::tcltest::ReportToMaster \ - {} ::tcltest::ReportedFromSlave - } - proc ReportedFromSlave {total passed skipped failed because newfiles} { - variable numTests - variable skippedBecause - variable createdNewFiles - incr numTests(Total) $total - incr numTests(Passed) $passed - incr numTests(Skipped) $skipped - incr numTests(Failed) $failed - foreach {constraint count} $because { - incr skippedBecause($constraint) $count - } - foreach {testfile created} $newfiles { - lappend createdNewFiles($testfile) {*}$created - } - return - } -} - -##################################################################### - -# tcltest::Debug* -- -# -# Internal helper procedures to write out debug information -# dependent on the chosen level. A test shell may overide -# them, f.e. to redirect the output into a different -# channel, or even into a GUI. - -# tcltest::DebugPuts -- -# -# Prints the specified string if the current debug level is -# higher than the provided level argument. -# -# Arguments: -# level The lowest debug level triggering the output -# string The string to print out. -# -# Results: -# Prints the string. Nothing else is allowed. -# -# Side Effects: -# None. -# - -proc tcltest::DebugPuts {level string} { - variable debug - if {$debug >= $level} { - puts $string - } - return -} - -# tcltest::DebugPArray -- -# -# Prints the contents of the specified array if the current -# debug level is higher than the provided level argument -# -# Arguments: -# level The lowest debug level triggering the output -# arrayvar The name of the array to print out. -# -# Results: -# Prints the contents of the array. Nothing else is allowed. -# -# Side Effects: -# None. -# - -proc tcltest::DebugPArray {level arrayvar} { - variable debug - - if {$debug >= $level} { - catch {upvar 1 $arrayvar $arrayvar} - parray $arrayvar - } - return -} - -# Define our own [parray] in ::tcltest that will inherit use of the [puts] -# defined in ::tcltest. NOTE: Ought to construct with [info args] and -# [info default], but can't be bothered now. If [parray] changes, then -# this will need changing too. -auto_load ::parray -proc tcltest::parray {a {pattern *}} [info body ::parray] - -# tcltest::DebugDo -- -# -# Executes the script if the current debug level is greater than -# the provided level argument -# -# Arguments: -# level The lowest debug level triggering the execution. -# script The tcl script executed upon a debug level high enough. -# -# Results: -# Arbitrary side effects, dependent on the executed script. -# -# Side Effects: -# None. -# - -proc tcltest::DebugDo {level script} { - variable debug - - if {$debug >= $level} { - uplevel 1 $script - } - return -} - -##################################################################### - -proc tcltest::Warn {msg} { - puts [outputChannel] "WARNING: $msg" -} - -# tcltest::mainThread -# -# Accessor command for tcltest variable mainThread. -# -proc tcltest::mainThread { {new ""} } { - variable mainThread - if {[llength [info level 0]] == 1} { - return $mainThread - } - set mainThread $new -} - -# tcltest::testConstraint -- -# -# sets a test constraint to a value; to do multiple constraints, -# call this proc multiple times. also returns the value of the -# named constraint if no value was supplied. -# -# Arguments: -# constraint - name of the constraint -# value - new value for constraint (should be boolean) - if not -# supplied, this is a query -# -# Results: -# content of tcltest::testConstraints($constraint) -# -# Side effects: -# none - -proc tcltest::testConstraint {constraint {value ""}} { - variable testConstraints - variable Option - DebugPuts 3 "entering testConstraint $constraint $value" - if {[llength [info level 0]] == 2} { - return $testConstraints($constraint) - } - # Check for boolean values - if {[catch {expr {$value && $value}} msg]} { - return -code error $msg - } - if {[limitConstraints] && ($constraint ni $Option(-constraints))} { - set value 0 - } - set testConstraints($constraint) $value -} - -# tcltest::interpreter -- -# -# the interpreter name stored in tcltest::tcltest -# -# Arguments: -# executable name -# -# Results: -# content of tcltest::tcltest -# -# Side effects: -# None. - -proc tcltest::interpreter { {interp ""} } { - variable tcltest - if {[llength [info level 0]] == 1} { - return $tcltest - } - set tcltest $interp -} - -##################################################################### - -# tcltest::AddToSkippedBecause -- -# -# Increments the variable used to track how many tests were -# skipped because of a particular constraint. -# -# Arguments: -# constraint The name of the constraint to be modified -# -# Results: -# Modifies tcltest::skippedBecause; sets the variable to 1 if -# didn't previously exist - otherwise, it just increments it. -# -# Side effects: -# None. - -proc tcltest::AddToSkippedBecause { constraint {value 1}} { - # add the constraint to the list of constraints that kept tests - # from running - variable skippedBecause - - if {[info exists skippedBecause($constraint)]} { - incr skippedBecause($constraint) $value - } else { - set skippedBecause($constraint) $value - } - return -} - -# tcltest::PrintError -- -# -# Prints errors to tcltest::errorChannel and then flushes that -# channel, making sure that all messages are < 80 characters per -# line. -# -# Arguments: -# errorMsg String containing the error to be printed -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::PrintError {errorMsg} { - set InitialMessage "Error: " - set InitialMsgLen [string length $InitialMessage] - puts -nonewline [errorChannel] $InitialMessage - - # Keep track of where the end of the string is. - set endingIndex [string length $errorMsg] - - if {$endingIndex < (80 - $InitialMsgLen)} { - puts [errorChannel] $errorMsg - } else { - # Print up to 80 characters on the first line, including the - # InitialMessage. - set beginningIndex [string last " " [string range $errorMsg 0 \ - [expr {80 - $InitialMsgLen}]]] - puts [errorChannel] [string range $errorMsg 0 $beginningIndex] - - while {$beginningIndex ne "end"} { - puts -nonewline [errorChannel] \ - [string repeat " " $InitialMsgLen] - if {($endingIndex - $beginningIndex) - < (80 - $InitialMsgLen)} { - puts [errorChannel] [string trim \ - [string range $errorMsg $beginningIndex end]] - break - } else { - set newEndingIndex [expr {[string last " " \ - [string range $errorMsg $beginningIndex \ - [expr {$beginningIndex - + (80 - $InitialMsgLen)}] - ]] + $beginningIndex}] - if {($newEndingIndex <= 0) - || ($newEndingIndex <= $beginningIndex)} { - set newEndingIndex end - } - puts [errorChannel] [string trim \ - [string range $errorMsg \ - $beginningIndex $newEndingIndex]] - set beginningIndex $newEndingIndex - } - } - } - flush [errorChannel] - return -} - -# tcltest::SafeFetch -- -# -# The following trace procedure makes it so that we can safely -# refer to non-existent members of the testConstraints array -# without causing an error. Instead, reading a non-existent -# member will return 0. This is necessary because tests are -# allowed to use constraint "X" without ensuring that -# testConstraints("X") is defined. -# -# Arguments: -# n1 - name of the array (testConstraints) -# n2 - array key value (constraint name) -# op - operation performed on testConstraints (generally r) -# -# Results: -# none -# -# Side effects: -# sets testConstraints($n2) to 0 if it's referenced but never -# before used - -proc tcltest::SafeFetch {n1 n2 op} { - variable testConstraints - DebugPuts 3 "entering SafeFetch $n1 $n2 $op" - if {$n2 eq {}} {return} - if {![info exists testConstraints($n2)]} { - if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} { - testConstraint $n2 0 - } - } -} - -# tcltest::ConstraintInitializer -- -# -# Get or set a script that when evaluated in the tcltest namespace -# will return a boolean value with which to initialize the -# associated constraint. -# -# Arguments: -# constraint - name of the constraint initialized by the script -# script - the initializer script -# -# Results -# boolean value of the constraint - enabled or disabled -# -# Side effects: -# Constraint is initialized for future reference by [test] -proc tcltest::ConstraintInitializer {constraint {script ""}} { - variable ConstraintInitializer - DebugPuts 3 "entering ConstraintInitializer $constraint $script" - if {[llength [info level 0]] == 2} { - return $ConstraintInitializer($constraint) - } - # Check for boolean values - if {![info complete $script]} { - return -code error "ConstraintInitializer must be complete script" - } - set ConstraintInitializer($constraint) $script -} - -# tcltest::InitConstraints -- -# -# Call all registered constraint initializers to force initialization -# of all known constraints. -# See the tcltest man page for the list of built-in constraints defined -# in this procedure. -# -# Arguments: -# none -# -# Results: -# The testConstraints array is reset to have an index for each -# built-in test constraint. -# -# Side Effects: -# None. -# - -proc tcltest::InitConstraints {} { - variable ConstraintInitializer - initConstraintsHook - foreach constraint [array names ConstraintInitializer] { - testConstraint $constraint - } -} - -proc tcltest::DefineConstraintInitializers {} { - ConstraintInitializer singleTestInterp {singleProcess} - - # All the 'pc' constraints are here for backward compatibility and - # are not documented. They have been replaced with equivalent 'win' - # constraints. - - ConstraintInitializer unixOnly \ - {string equal $::tcl_platform(platform) unix} - ConstraintInitializer macOnly \ - {string equal $::tcl_platform(platform) macintosh} - ConstraintInitializer pcOnly \ - {string equal $::tcl_platform(platform) windows} - ConstraintInitializer winOnly \ - {string equal $::tcl_platform(platform) windows} - - ConstraintInitializer unix {testConstraint unixOnly} - ConstraintInitializer mac {testConstraint macOnly} - ConstraintInitializer pc {testConstraint pcOnly} - ConstraintInitializer win {testConstraint winOnly} - - ConstraintInitializer unixOrPc \ - {expr {[testConstraint unix] || [testConstraint pc]}} - ConstraintInitializer macOrPc \ - {expr {[testConstraint mac] || [testConstraint pc]}} - ConstraintInitializer unixOrWin \ - {expr {[testConstraint unix] || [testConstraint win]}} - ConstraintInitializer macOrWin \ - {expr {[testConstraint mac] || [testConstraint win]}} - ConstraintInitializer macOrUnix \ - {expr {[testConstraint mac] || [testConstraint unix]}} - - ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"} - ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"} - ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"} - - # The following Constraints switches are used to mark tests that - # should work, but have been temporarily disabled on certain - # platforms because they don't and we haven't gotten around to - # fixing the underlying problem. - - ConstraintInitializer tempNotPc {expr {![testConstraint pc]}} - ConstraintInitializer tempNotWin {expr {![testConstraint win]}} - ConstraintInitializer tempNotMac {expr {![testConstraint mac]}} - ConstraintInitializer tempNotUnix {expr {![testConstraint unix]}} - - # The following Constraints switches are used to mark tests that - # crash on certain platforms, so that they can be reactivated again - # when the underlying problem is fixed. - - ConstraintInitializer pcCrash {expr {![testConstraint pc]}} - ConstraintInitializer winCrash {expr {![testConstraint win]}} - ConstraintInitializer macCrash {expr {![testConstraint mac]}} - ConstraintInitializer unixCrash {expr {![testConstraint unix]}} - - # Skip empty tests - - ConstraintInitializer emptyTest {format 0} - - # By default, tests that expose known bugs are skipped. - - ConstraintInitializer knownBug {format 0} - - # By default, non-portable tests are skipped. - - ConstraintInitializer nonPortable {format 0} - - # Some tests require user interaction. - - ConstraintInitializer userInteraction {format 0} - - # Some tests must be skipped if the interpreter is not in - # interactive mode - - ConstraintInitializer interactive \ - {expr {[info exists ::tcl_interactive] && $::tcl_interactive}} - - # Some tests can only be run if the installation came from a CD - # image instead of a web image. Some tests must be skipped if you - # are running as root on Unix. Other tests can only be run if you - # are running as root on Unix. - - ConstraintInitializer root {expr \ - {($::tcl_platform(platform) eq "unix") && - ($::tcl_platform(user) in {root {}})}} - ConstraintInitializer notRoot {expr {![testConstraint root]}} - - # Set nonBlockFiles constraint: 1 means this platform supports - # setting files into nonblocking mode. - - ConstraintInitializer nonBlockFiles { - set code [expr {[catch {set f [open defs r]}] - || [catch {chan configure $f -blocking off}]}] - catch {close $f} - set code - } - - # Set asyncPipeClose constraint: 1 means this platform supports - # async flush and async close on a pipe. - # - # Test for SCO Unix - cannot run async flushing tests because a - # potential problem with select is apparently interfering. - # (Mark Diekhans). - - ConstraintInitializer asyncPipeClose {expr { - !([string equal unix $::tcl_platform(platform)] - && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}} - - # Test to see if we have a broken version of sprintf with respect - # to the "e" format of floating-point numbers. - - ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05} - - # Test to see if execed commands such as cat, echo, rm and so forth - # are present on this machine. - - ConstraintInitializer unixExecs { - set code 1 - if {$::tcl_platform(platform) eq "macintosh"} { - set code 0 - } - if {$::tcl_platform(platform) eq "windows"} { - if {[catch { - set file _tcl_test_remove_me.txt - makeFile {hello} $file - }]} { - set code 0 - } elseif { - [catch {exec cat $file}] || - [catch {exec echo hello}] || - [catch {exec sh -c echo hello}] || - [catch {exec wc $file}] || - [catch {exec sleep 1}] || - [catch {exec echo abc > $file}] || - [catch {exec chmod 644 $file}] || - [catch {exec rm $file}] || - [llength [auto_execok mkdir]] == 0 || - [llength [auto_execok fgrep]] == 0 || - [llength [auto_execok grep]] == 0 || - [llength [auto_execok ps]] == 0 - } { - set code 0 - } - removeFile $file - } - set code - } - - ConstraintInitializer stdio { - set code 0 - if {![catch {set f [open "|[list [interpreter]]" w]}]} { - if {![catch {puts $f exit}]} { - if {![catch {close $f}]} { - set code 1 - } - } - } - set code - } - - # Deliberately call socket with the wrong number of arguments. The - # error message you get will indicate whether sockets are available - # on this system. - - ConstraintInitializer socket { - catch {socket} msg - string compare $msg "sockets are not available on this system" - } - - # Check for internationalization - ConstraintInitializer hasIsoLocale { - if {[llength [info commands testlocale]] == 0} { - set code 0 - } else { - set code [string length [SetIso8859_1_Locale]] - RestoreLocale - } - set code - } - -} -##################################################################### - -# Usage and command line arguments processing. - -# tcltest::PrintUsageInfo -# -# Prints out the usage information for package tcltest. This can -# be customized with the redefinition of [PrintUsageInfoHook]. -# -# Arguments: -# none -# -# Results: -# none -# -# Side Effects: -# none -proc tcltest::PrintUsageInfo {} { - puts [Usage] - PrintUsageInfoHook -} - -proc tcltest::Usage { {option ""} } { - variable Usage - variable Verify - if {[llength [info level 0]] == 1} { - set msg "Usage: [file tail [info nameofexecutable]] script " - append msg "?-help? ?flag value? ... \n" - append msg "Available flags (and valid input values) are:" - - set max 0 - set allOpts [concat -help [Configure]] - foreach opt $allOpts { - set foo [Usage $opt] - lassign $foo x type($opt) usage($opt) - set line($opt) " $opt $type($opt) " - set length($opt) [string length $line($opt)] - if {$length($opt) > $max} {set max $length($opt)} - } - set rest [expr {72 - $max}] - foreach opt $allOpts { - append msg \n$line($opt) - append msg [string repeat " " [expr {$max - $length($opt)}]] - set u [string trim $usage($opt)] - catch {append u " (default: \[[Configure $opt]])"} - regsub -all {\s*\n\s*} $u " " u - while {[string length $u] > $rest} { - set break [string wordstart $u $rest] - if {$break == 0} { - set break [string wordend $u 0] - } - append msg [string range $u 0 [expr {$break - 1}]] - set u [string trim [string range $u $break end]] - append msg \n[string repeat " " $max] - } - append msg $u - } - return $msg\n - } elseif {$option eq "-help"} { - return [list -help "" "Display this usage information."] - } else { - set type [lindex [info args $Verify($option)] 0] - return [list $option $type $Usage($option)] - } -} - -# tcltest::ProcessFlags -- -# -# process command line arguments supplied in the flagArray - this -# is called by processCmdLineArgs. Modifies tcltest variables -# according to the content of the flagArray. -# -# Arguments: -# flagArray - array containing name/value pairs of flags -# -# Results: -# sets tcltest variables according to their values as defined by -# flagArray -# -# Side effects: -# None. - -proc tcltest::ProcessFlags {flagArray} { - # Process -help first - if {"-help" in $flagArray} { - PrintUsageInfo - exit 1 - } - - if {[llength $flagArray] == 0} { - RemoveAutoConfigureTraces - } else { - set args $flagArray - while {[llength $args] > 1 && [catch {configure {*}$args} msg]} { - - # Something went wrong parsing $args for tcltest options - # Check whether the problem is "unknown option" - if {[regexp {^unknown option (\S+):} $msg -> option]} { - # Could be this is an option the Hook knows about - set moreOptions [processCmdLineArgsAddFlagsHook] - if {$option ni $moreOptions} { - # Nope. Report the error, including additional options, - # but keep going - if {[llength $moreOptions]} { - append msg ", " - append msg [join [lrange $moreOptions 0 end-1] ", "] - append msg "or [lindex $moreOptions end]" - } - Warn $msg - } - } else { - # error is something other than "unknown option" - # notify user of the error; and exit - puts [errorChannel] $msg - exit 1 - } - - # To recover, find that unknown option and remove up to it. - # then retry - while {[lindex $args 0] ne $option} { - set args [lrange $args 2 end] - } - set args [lrange $args 2 end] - } - if {[llength $args] == 1} { - puts [errorChannel] \ - "missing value for option [lindex $args 0]" - exit 1 - } - } - - # Call the hook - catch { - array set flag $flagArray - processCmdLineArgsHook [array get flag] - } - return -} - -# tcltest::ProcessCmdLineArgs -- -# -# This procedure must be run after constraint initialization is -# set up (by [DefineConstraintInitializers]) because some constraints -# can be overridden. -# -# Perform configuration according to the command-line options. -# -# Arguments: -# none -# -# Results: -# Sets the above-named variables in the tcltest namespace. -# -# Side Effects: -# None. -# - -proc tcltest::ProcessCmdLineArgs {} { - variable originalEnv - variable testConstraints - - # The "argv" var doesn't exist in some cases, so use {}. - if {![info exists ::argv]} { - ProcessFlags {} - } else { - ProcessFlags $::argv - } - - # Spit out everything you know if we're at a debug level 2 or - # greater - DebugPuts 2 "Flags passed into tcltest:" - if {[info exists ::env(TCLTEST_OPTIONS)]} { - DebugPuts 2 \ - " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)" - } - if {[info exists ::argv]} { - DebugPuts 2 " argv: $::argv" - } - DebugPuts 2 "tcltest::debug = [debug]" - DebugPuts 2 "tcltest::testsDirectory = [testsDirectory]" - DebugPuts 2 "tcltest::workingDirectory = [workingDirectory]" - DebugPuts 2 "tcltest::temporaryDirectory = [temporaryDirectory]" - DebugPuts 2 "tcltest::outputChannel = [outputChannel]" - DebugPuts 2 "tcltest::errorChannel = [errorChannel]" - DebugPuts 2 "Original environment (tcltest::originalEnv):" - DebugPArray 2 originalEnv - DebugPuts 2 "Constraints:" - DebugPArray 2 testConstraints -} - -##################################################################### - -# Code to run the tests goes here. - -# tcltest::TestPuts -- -# -# Used to redefine puts in test environment. Stores whatever goes -# out on stdout in tcltest::outData and stderr in errData before -# sending it on to the regular puts. -# -# Arguments: -# same as standard puts -# -# Results: -# none -# -# Side effects: -# Intercepts puts; data that would otherwise go to stdout, stderr, -# or file channels specified in outputChannel and errorChannel -# does not get sent to the normal puts function. -namespace eval tcltest::Replace { - namespace export puts -} -proc tcltest::Replace::puts {args} { - variable [namespace parent]::outData - variable [namespace parent]::errData - switch [llength $args] { - 1 { - # Only the string to be printed is specified - append outData [lindex $args 0]\n - return - # return [Puts [lindex $args 0]] - } - 2 { - # Either -nonewline or channelId has been specified - if {[lindex $args 0] eq "-nonewline"} { - append outData [lindex $args end] - return - # return [Puts -nonewline [lindex $args end]] - } else { - set channel [lindex $args 0] - set newline \n - } - } - 3 { - if {[lindex $args 0] eq "-nonewline"} { - # Both -nonewline and channelId are specified, unless - # it's an error. -nonewline is supposed to be argv[0]. - set channel [lindex $args 1] - set newline "" - } - } - } - - if {[info exists channel]} { - if {$channel in [list [[namespace parent]::outputChannel] stdout]} { - append outData [lindex $args end]$newline - return - } elseif {$channel in [list [[namespace parent]::errorChannel] stderr]} { - append errData [lindex $args end]$newline - return - } - } - - # If we haven't returned by now, we don't know how to handle the - # input. Let puts handle it. - return [Puts {*}$args] -} - -# tcltest::Eval -- -# -# Evaluate the script in the test environment. If ignoreOutput is -# false, store data sent to stderr and stdout in outData and -# errData. Otherwise, ignore this output altogether. -# -# Arguments: -# script Script to evaluate -# ?ignoreOutput? Indicates whether or not to ignore output -# sent to stdout & stderr -# -# Results: -# result from running the script -# -# Side effects: -# Empties the contents of outData and errData before running a -# test if ignoreOutput is set to 0. - -proc tcltest::Eval {script {ignoreOutput 1}} { - variable outData - variable errData - DebugPuts 3 "[lindex [info level 0] 0] called" - if {!$ignoreOutput} { - set outData {} - set errData {} - rename ::puts [namespace current]::Replace::Puts - namespace eval :: [list namespace import [namespace origin Replace::puts]] - namespace import Replace::puts - } - set result [uplevel 1 $script] - if {!$ignoreOutput} { - namespace forget puts - namespace eval :: namespace forget puts - rename [namespace current]::Replace::Puts ::puts - } - return $result -} - -# tcltest::CompareStrings -- -# -# compares the expected answer to the actual answer, depending on -# the mode provided. Mode determines whether a regexp, exact, -# glob or custom comparison is done. -# -# Arguments: -# actual - string containing the actual result -# expected - pattern to be matched against -# mode - type of comparison to be done -# -# Results: -# result of the match -# -# Side effects: -# None. - -proc tcltest::CompareStrings {actual expected mode} { - variable CustomMatch - if {![info exists CustomMatch($mode)]} { - return -code error "No matching command registered for `-match $mode'" - } - set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]] - if {[catch {expr {$match && $match}} result]} { - return -code error "Invalid result from `-match $mode' command: $result" - } - return $match -} - -# tcltest::customMatch -- -# -# registers a command to be called when a particular type of -# matching is required. -# -# Arguments: -# nickname - Keyword for the type of matching -# cmd - Incomplete command that implements that type of matching -# when completed with expected string and actual string -# and then evaluated. -# -# Results: -# None. -# -# Side effects: -# Sets the variable tcltest::CustomMatch - -proc tcltest::customMatch {mode script} { - variable CustomMatch - if {![info complete $script]} { - return -code error \ - "invalid customMatch script; can't evaluate after completion" - } - set CustomMatch($mode) $script -} - -# tcltest::SubstArguments list -# -# This helper function takes in a list of words, then perform a -# substitution on the list as though each word in the list is a separate -# argument to the Tcl function. For example, if this function is -# invoked as: -# -# SubstArguments {$a {$a}} -# -# Then it is as though the function is invoked as: -# -# SubstArguments $a {$a} -# -# This code is adapted from Paul Duffin's function "SplitIntoWords". -# The original function can be found on: -# -# http://purl.org/thecliff/tcl/wiki/858.html -# -# Results: -# a list containing the result of the substitution -# -# Exceptions: -# An error may occur if the list containing unbalanced quote or -# unknown variable. -# -# Side Effects: -# None. -# - -proc tcltest::SubstArguments {argList} { - - # We need to split the argList up into tokens but cannot use list - # operations as they throw away some significant quoting, and - # [split] ignores braces as it should. Therefore what we do is - # gradually build up a string out of whitespace seperated strings. - # We cannot use [split] to split the argList into whitespace - # separated strings as it throws away the whitespace which maybe - # important so we have to do it all by hand. - - set result {} - set token "" - - while {[string length $argList]} { - # Look for the next word containing a quote: " { } - if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \ - $argList all]} { - # Get the text leading up to this word, but not including - # this word, from the argList. - set text [string range $argList 0 \ - [expr {[lindex $all 0] - 1}]] - # Get the word with the quote - set word [string range $argList \ - [lindex $all 0] [lindex $all 1]] - - # Remove all text up to and including the word from the - # argList. - set argList [string range $argList \ - [expr {[lindex $all 1] + 1}] end] - } else { - # Take everything up to the end of the argList. - set text $argList - set word {} - set argList {} - } - - if {$token ne {}} { - # If we saw a word with quote before, then there is a - # multi-word token starting with that word. In this case, - # add the text and the current word to this token. - append token $text $word - } else { - # Add the text to the result. There is no need to parse - # the text because it couldn't be a part of any multi-word - # token. Then start a new multi-word token with the word - # because we need to pass this token to the Tcl parser to - # check for balancing quotes - append result $text - set token $word - } - - if { [catch {llength $token} length] == 0 && $length == 1} { - # The token is a valid list so add it to the result. - # lappend result [string trim $token] - append result \{$token\} - set token {} - } - } - - # If the last token has not been added to the list then there - # is a problem. - if { [string length $token] } { - error "incomplete token \"$token\"" - } - - return $result -} - - -# tcltest::test -- -# -# This procedure runs a test and prints an error message if the test -# fails. If verbose has been set, it also prints a message even if the -# test succeeds. The test will be skipped if it doesn't match the -# match variable, if it matches an element in skip, or if one of the -# elements of "constraints" turns out not to be true. -# -# If testLevel is 1, then this is a top level test, and we record -# pass/fail information; otherwise, this information is not logged and -# is not added to running totals. -# -# Attributes: -# Only description is a required attribute. All others are optional. -# Default values are indicated. -# -# constraints - A list of one or more keywords, each of which -# must be the name of an element in the array -# "testConstraints". If any of these elements is -# zero, the test is skipped. This attribute is -# optional; default is {} -# body - Script to run to carry out the test. It must -# return a result that can be checked for -# correctness. This attribute is optional; -# default is {} -# result - Expected result from script. This attribute is -# optional; default is {}. -# output - Expected output sent to stdout. This attribute -# is optional; default is {}. -# errorOutput - Expected output sent to stderr. This attribute -# is optional; default is {}. -# returnCodes - Expected return codes. This attribute is -# optional; default is {0 2}. -# setup - Code to run before $script (above). This -# attribute is optional; default is {}. -# cleanup - Code to run after $script (above). This -# attribute is optional; default is {}. -# match - specifies type of matching to do on result, -# output, errorOutput; this must be a string -# previously registered by a call to [customMatch]. -# The strings exact, glob, and regexp are pre-registered -# by the tcltest package. Default value is exact. -# -# Arguments: -# name - Name of test, in the form foo-1.2. -# description - Short textual description of the test, to -# help humans understand what it does. -# -# Results: -# None. -# -# Side effects: -# Just about anything is possible depending on the test. -# - -proc tcltest::test {name description args} { - global tcl_platform - variable testLevel - variable coreModTime - DebugPuts 3 "test $name $args" - DebugDo 1 { - variable TestNames - catch { - puts "test name '$name' re-used; prior use in $TestNames($name)" - } - set TestNames($name) [info script] - } - - FillFilesExisted - incr testLevel - - # Pre-define everything to null except output and errorOutput. We - # determine whether or not to trap output based on whether or not - # these variables (output & errorOutput) are defined. - lassign {} constraints setup cleanup body result returnCodes match - - # Set the default match mode - set match exact - - # Set the default match values for return codes (0 is the standard - # expected return value if everything went well; 2 represents - # 'return' being used in the test script). - set returnCodes [list 0 2] - - # The old test format can't have a 3rd argument (constraints or - # script) that starts with '-'. - if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} { - if {[llength $args] == 1} { - set list [SubstArguments [lindex $args 0]] - foreach {element value} $list { - set testAttributes($element) $value - } - foreach item {constraints match setup body cleanup \ - result returnCodes output errorOutput} { - if {[info exists testAttributes(-$item)]} { - set testAttributes(-$item) [uplevel 1 \ - ::concat $testAttributes(-$item)] - } - } - } else { - array set testAttributes $args - } - - set validFlags {-setup -cleanup -body -result -returnCodes \ - -match -output -errorOutput -constraints} - - foreach flag [array names testAttributes] { - if {$flag ni $validFlags} { - incr testLevel -1 - set sorted [lsort $validFlags] - set options [join [lrange $sorted 0 end-1] ", "] - append options ", or [lindex $sorted end]" - return -code error "bad option \"$flag\": must be $options" - } - } - - # store whatever the user gave us - foreach item [array names testAttributes] { - set [string trimleft $item "-"] $testAttributes($item) - } - - # Check the values supplied for -match - variable CustomMatch - if {$match ni [array names CustomMatch]} { - incr testLevel -1 - set sorted [lsort [array names CustomMatch]] - set values [join [lrange $sorted 0 end-1] ", "] - append values ", or [lindex $sorted end]" - return -code error "bad -match value \"$match\":\ - must be $values" - } - - # Replace symbolic valies supplied for -returnCodes - foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} { - set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes] - } - } else { - # This is parsing for the old test command format; it is here - # for backward compatibility. - set result [lindex $args end] - if {[llength $args] == 2} { - set body [lindex $args 0] - } elseif {[llength $args] == 3} { - set constraints [lindex $args 0] - set body [lindex $args 1] - } else { - incr testLevel -1 - return -code error "wrong # args:\ - should be \"test name desc ?options?\"" - } - } - - if {[Skipped $name $constraints]} { - incr testLevel -1 - return - } - - # Save information about the core file. - if {[preserveCore]} { - if {[file exists [file join [workingDirectory] core]]} { - set coreModTime [file mtime [file join [workingDirectory] core]] - } - } - - # First, run the setup script - set code [catch {uplevel 1 $setup} setupMsg] - if {$code == 1} { - set errorInfo(setup) $::errorInfo - set errorCode(setup) $::errorCode - } - set setupFailure [expr {$code != 0}] - - # Only run the test body if the setup was successful - if {!$setupFailure} { - - # Register startup time - if {[IsVerbose msec] || [IsVerbose usec]} { - set timeStart [clock microseconds] - } - - # Verbose notification of $body start - if {[IsVerbose start]} { - puts [outputChannel] "---- $name start" - flush [outputChannel] - } - - set command [list [namespace origin RunTest] $name $body] - if {[info exists output] || [info exists errorOutput]} { - set testResult [uplevel 1 [list [namespace origin Eval] $command 0]] - } else { - set testResult [uplevel 1 [list [namespace origin Eval] $command 1]] - } - lassign $testResult actualAnswer returnCode - if {$returnCode == 1} { - set errorInfo(body) $::errorInfo - set errorCode(body) $::errorCode - } - } - - # check if the return code matched the expected return code - set codeFailure 0 - if {!$setupFailure && ($returnCode ni $returnCodes)} { - set codeFailure 1 - } - - # If expected output/error strings exist, we have to compare - # them. If the comparison fails, then so did the test. - set outputFailure 0 - variable outData - if {[info exists output] && !$codeFailure} { - if {[set outputCompare [catch { - CompareStrings $outData $output $match - } outputMatch]] == 0} { - set outputFailure [expr {!$outputMatch}] - } else { - set outputFailure 1 - } - } - - set errorFailure 0 - variable errData - if {[info exists errorOutput] && !$codeFailure} { - if {[set errorCompare [catch { - CompareStrings $errData $errorOutput $match - } errorMatch]] == 0} { - set errorFailure [expr {!$errorMatch}] - } else { - set errorFailure 1 - } - } - - # check if the answer matched the expected answer - # Only check if we ran the body of the test (no setup failure) - if {$setupFailure || $codeFailure} { - set scriptFailure 0 - } elseif {[set scriptCompare [catch { - CompareStrings $actualAnswer $result $match - } scriptMatch]] == 0} { - set scriptFailure [expr {!$scriptMatch}] - } else { - set scriptFailure 1 - } - - # Always run the cleanup script - set code [catch {uplevel 1 $cleanup} cleanupMsg] - if {$code == 1} { - set errorInfo(cleanup) $::errorInfo - set errorCode(cleanup) $::errorCode - } - set cleanupFailure [expr {$code != 0}] - - set coreFailure 0 - set coreMsg "" - # check for a core file first - if one was created by the test, - # then the test failed - if {[preserveCore]} { - if {[file exists [file join [workingDirectory] core]]} { - # There's only a test failure if there is a core file - # and (1) there previously wasn't one or (2) the new - # one is different from the old one. - if {[info exists coreModTime]} { - if {$coreModTime != [file mtime \ - [file join [workingDirectory] core]]} { - set coreFailure 1 - } - } else { - set coreFailure 1 - } - - if {([preserveCore] > 1) && ($coreFailure)} { - append coreMsg "\nMoving file to:\ - [file join [temporaryDirectory] core-$name]" - catch {file rename -force -- \ - [file join [workingDirectory] core] \ - [file join [temporaryDirectory] core-$name] - } msg - if {$msg ne {}} { - append coreMsg "\nError:\ - Problem renaming core file: $msg" - } - } - } - } - - if {[IsVerbose msec] || [IsVerbose usec]} { - set t [expr {[clock microseconds] - $timeStart}] - if {[IsVerbose usec]} { - puts [outputChannel] "++++ $name took $t μs" - } - if {[IsVerbose msec]} { - puts [outputChannel] "++++ $name took [expr {round($t/1000.)}] ms" - } - } - - # if we didn't experience any failures, then we passed - variable numTests - if {!($setupFailure || $cleanupFailure || $coreFailure - || $outputFailure || $errorFailure || $codeFailure - || $scriptFailure)} { - if {$testLevel == 1} { - incr numTests(Passed) - if {[IsVerbose pass]} { - puts [outputChannel] "++++ $name PASSED" - } - } - incr testLevel -1 - return - } - - # We know the test failed, tally it... - if {$testLevel == 1} { - incr numTests(Failed) - } - - # ... then report according to the type of failure - variable currentFailure true - if {![IsVerbose body]} { - set body "" - } - puts [outputChannel] "\n" - if {[IsVerbose line]} { - if {![catch {set testFrame [info frame -1]}] && - [dict get $testFrame type] eq "source"} { - set testFile [dict get $testFrame file] - set testLine [dict get $testFrame line] - } else { - set testFile [file normalize [uplevel 1 {info script}]] - if {[file readable $testFile]} { - set testFd [open $testFile r] - set testLine [expr {[lsearch -regexp \ - [split [read $testFd] "\n"] \ - "^\[ \t\]*test [string map {. \\.} $name] "] + 1}] - close $testFd - } - } - if {[info exists testLine]} { - puts [outputChannel] "$testFile:$testLine: error: test failed:\ - $name [string trim $description]" - } - } - puts [outputChannel] "==== $name\ - [string trim $description] FAILED" - if {[string length $body]} { - puts [outputChannel] "==== Contents of test case:" - puts [outputChannel] $body - } - if {$setupFailure} { - puts [outputChannel] "---- Test setup\ - failed:\n$setupMsg" - if {[info exists errorInfo(setup)]} { - puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)" - puts [outputChannel] "---- errorCode(setup): $errorCode(setup)" - } - } - if {$scriptFailure} { - if {$scriptCompare} { - puts [outputChannel] "---- Error testing result: $scriptMatch" - } else { - puts [outputChannel] "---- Result was:\n$actualAnswer" - puts [outputChannel] "---- Result should have been\ - ($match matching):\n$result" - } - } - if {$codeFailure} { - switch -- $returnCode { - 0 { set msg "Test completed normally" } - 1 { set msg "Test generated error" } - 2 { set msg "Test generated return exception" } - 3 { set msg "Test generated break exception" } - 4 { set msg "Test generated continue exception" } - default { set msg "Test generated exception" } - } - puts [outputChannel] "---- $msg; Return code was: $returnCode" - puts [outputChannel] "---- Return code should have been\ - one of: $returnCodes" - if {[IsVerbose error]} { - if {[info exists errorInfo(body)] && (1 ni $returnCodes)} { - puts [outputChannel] "---- errorInfo: $errorInfo(body)" - puts [outputChannel] "---- errorCode: $errorCode(body)" - } - } - } - if {$outputFailure} { - if {$outputCompare} { - puts [outputChannel] "---- Error testing output: $outputMatch" - } else { - puts [outputChannel] "---- Output was:\n$outData" - puts [outputChannel] "---- Output should have been\ - ($match matching):\n$output" - } - } - if {$errorFailure} { - if {$errorCompare} { - puts [outputChannel] "---- Error testing errorOutput: $errorMatch" - } else { - puts [outputChannel] "---- Error output was:\n$errData" - puts [outputChannel] "---- Error output should have\ - been ($match matching):\n$errorOutput" - } - } - if {$cleanupFailure} { - puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" - if {[info exists errorInfo(cleanup)]} { - puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)" - puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)" - } - } - if {$coreFailure} { - puts [outputChannel] "---- Core file produced while running\ - test! $coreMsg" - } - puts [outputChannel] "==== $name FAILED\n" - - incr testLevel -1 - return -} - -# Skipped -- -# -# Given a test name and it constraints, returns a boolean indicating -# whether the current configuration says the test should be skipped. -# -# Side Effects: Maintains tally of total tests seen and tests skipped. -# -proc tcltest::Skipped {name constraints} { - variable testLevel - variable numTests - variable testConstraints - - if {$testLevel == 1} { - incr numTests(Total) - } - # skip the test if it's name matches an element of skip - foreach pattern [skip] { - if {[string match $pattern $name]} { - if {$testLevel == 1} { - incr numTests(Skipped) - DebugDo 1 {AddToSkippedBecause userSpecifiedSkip} - } - return 1 - } - } - # skip the test if it's name doesn't match any element of match - set ok 0 - foreach pattern [match] { - if {[string match $pattern $name]} { - set ok 1 - break - } - } - if {!$ok} { - if {$testLevel == 1} { - incr numTests(Skipped) - DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch} - } - return 1 - } - if {$constraints eq {}} { - # If we're limited to the listed constraints and there aren't - # any listed, then we shouldn't run the test. - if {[limitConstraints]} { - AddToSkippedBecause userSpecifiedLimitConstraint - if {$testLevel == 1} { - incr numTests(Skipped) - } - return 1 - } - } else { - # "constraints" argument exists; - # make sure that the constraints are satisfied. - - set doTest 0 - if {[string match {*[$\[]*} $constraints] != 0} { - # full expression, e.g. {$foo > [info tclversion]} - catch {set doTest [uplevel #0 [list expr $constraints]]} - } elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} { - # something like {a || b} should be turned into - # $testConstraints(a) || $testConstraints(b). - regsub -all {[.\w]+} $constraints {$testConstraints(&)} c - catch {set doTest [eval [list expr $c]]} - } elseif {![catch {llength $constraints}]} { - # just simple constraints such as {unixOnly fonts}. - set doTest 1 - foreach constraint $constraints { - if {(![info exists testConstraints($constraint)]) \ - || (!$testConstraints($constraint))} { - set doTest 0 - - # store the constraint that kept the test from - # running - set constraints $constraint - break - } - } - } - - if {!$doTest} { - if {[IsVerbose skip]} { - puts [outputChannel] "++++ $name SKIPPED: $constraints" - } - - if {$testLevel == 1} { - incr numTests(Skipped) - AddToSkippedBecause $constraints - } - return 1 - } - } - return 0 -} - -# RunTest -- -# -# This is where the body of a test is evaluated. The combination of -# [RunTest] and [Eval] allows the output and error output of the test -# body to be captured for comparison against the expected values. - -proc tcltest::RunTest {name script} { - DebugPuts 3 "Running $name {$script}" - - # If there is no "memory" command (because memory debugging isn't - # enabled), then don't attempt to use the command. - - if {[llength [info commands memory]] == 1} { - memory tag $name - } - - set code [catch {uplevel 1 $script} actualAnswer] - - return [list $actualAnswer $code] -} - -##################################################################### - -# tcltest::cleanupTestsHook -- -# -# This hook allows a harness that builds upon tcltest to specify -# additional things that should be done at cleanup. -# - -if {[llength [info commands tcltest::cleanupTestsHook]] == 0} { - proc tcltest::cleanupTestsHook {} {} -} - -# tcltest::cleanupTests -- -# -# Remove files and dirs created using the makeFile and makeDirectory -# commands since the last time this proc was invoked. -# -# Print the names of the files created without the makeFile command -# since the tests were invoked. -# -# Print the number tests (total, passed, failed, and skipped) since the -# tests were invoked. -# -# Restore original environment (as reported by special variable env). -# -# Arguments: -# calledFromAllFile - if 0, behave as if we are running a single -# test file within an entire suite of tests. if we aren't running -# a single test file, then don't report status. check for new -# files created during the test run and report on them. if 1, -# report collated status from all the test file runs. -# -# Results: -# None. -# -# Side Effects: -# None -# - -proc tcltest::cleanupTests {{calledFromAllFile 0}} { - variable filesMade - variable filesExisted - variable createdNewFiles - variable testSingleFile - variable numTests - variable numTestFiles - variable failFiles - variable skippedBecause - variable currentFailure - variable originalEnv - variable originalTclPlatform - variable coreModTime - - FillFilesExisted - set testFileName [file tail [info script]] - - # Hook to handle reporting to a parent interpreter - if {[llength [info commands [namespace current]::ReportToMaster]]} { - ReportToMaster $numTests(Total) $numTests(Passed) $numTests(Skipped) \ - $numTests(Failed) [array get skippedBecause] \ - [array get createdNewFiles] - set testSingleFile false - } - - # Call the cleanup hook - cleanupTestsHook - - # Remove files and directories created by the makeFile and - # makeDirectory procedures. Record the names of files in - # workingDirectory that were not pre-existing, and associate them - # with the test file that created them. - - if {!$calledFromAllFile} { - foreach file $filesMade { - if {[file exists $file]} { - DebugDo 1 {Warn "cleanupTests deleting $file..."} - catch {file delete -force -- $file} - } - } - set currentFiles {} - foreach file [glob -nocomplain \ - -directory [temporaryDirectory] *] { - lappend currentFiles [file tail $file] - } - set newFiles {} - foreach file $currentFiles { - if {$file ni $filesExisted} { - lappend newFiles $file - } - } - set filesExisted $currentFiles - if {[llength $newFiles] > 0} { - set createdNewFiles($testFileName) $newFiles - } - } - - if {$calledFromAllFile || $testSingleFile} { - - # print stats - - puts -nonewline [outputChannel] "$testFileName:" - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - puts -nonewline [outputChannel] \ - "\t$index\t$numTests($index)" - } - puts [outputChannel] "" - - # print number test files sourced - # print names of files that ran tests which failed - - if {$calledFromAllFile} { - puts [outputChannel] \ - "Sourced $numTestFiles Test Files." - set numTestFiles 0 - if {[llength $failFiles] > 0} { - puts [outputChannel] \ - "Files with failing tests: $failFiles" - set failFiles {} - } - } - - # if any tests were skipped, print the constraints that kept - # them from running. - - set constraintList [array names skippedBecause] - if {[llength $constraintList] > 0} { - puts [outputChannel] \ - "Number of tests skipped for each constraint:" - foreach constraint [lsort $constraintList] { - puts [outputChannel] \ - "\t$skippedBecause($constraint)\t$constraint" - unset skippedBecause($constraint) - } - } - - # report the names of test files in createdNewFiles, and reset - # the array to be empty. - - set testFilesThatTurded [lsort [array names createdNewFiles]] - if {[llength $testFilesThatTurded] > 0} { - puts [outputChannel] "Warning: files left behind:" - foreach testFile $testFilesThatTurded { - puts [outputChannel] \ - "\t$testFile:\t$createdNewFiles($testFile)" - unset createdNewFiles($testFile) - } - } - - # reset filesMade, filesExisted, and numTests - - set filesMade {} - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - set numTests($index) 0 - } - - # exit only if running Tk in non-interactive mode - # This should be changed to determine if an event - # loop is running, which is the real issue. - # Actually, this doesn't belong here at all. A package - # really has no business [exit]-ing an application. - if {![catch {package present Tk}] && ![testConstraint interactive]} { - exit - } - } else { - - # if we're deferring stat-reporting until all files are sourced, - # then add current file to failFile list if any tests in this - # file failed - - if {$currentFailure && ($testFileName ni $failFiles)} { - lappend failFiles $testFileName - } - set currentFailure false - - # restore the environment to the state it was in before this package - # was loaded - - set newEnv {} - set changedEnv {} - set removedEnv {} - foreach index [array names ::env] { - if {![info exists originalEnv($index)]} { - lappend newEnv $index - unset ::env($index) - } - } - foreach index [array names originalEnv] { - if {![info exists ::env($index)]} { - lappend removedEnv $index - set ::env($index) $originalEnv($index) - } elseif {$::env($index) ne $originalEnv($index)} { - lappend changedEnv $index - set ::env($index) $originalEnv($index) - } - } - if {[llength $newEnv] > 0} { - puts [outputChannel] \ - "env array elements created:\t$newEnv" - } - if {[llength $changedEnv] > 0} { - puts [outputChannel] \ - "env array elements changed:\t$changedEnv" - } - if {[llength $removedEnv] > 0} { - puts [outputChannel] \ - "env array elements removed:\t$removedEnv" - } - - set changedTclPlatform {} - foreach index [array names originalTclPlatform] { - if {$::tcl_platform($index) \ - != $originalTclPlatform($index)} { - lappend changedTclPlatform $index - set ::tcl_platform($index) $originalTclPlatform($index) - } - } - if {[llength $changedTclPlatform] > 0} { - puts [outputChannel] "tcl_platform array elements\ - changed:\t$changedTclPlatform" - } - - if {[file exists [file join [workingDirectory] core]]} { - if {[preserveCore] > 1} { - puts "rename core file (> 1)" - puts [outputChannel] "produced core file! \ - Moving file to: \ - [file join [temporaryDirectory] core-$testFileName]" - catch {file rename -force -- \ - [file join [workingDirectory] core] \ - [file join [temporaryDirectory] core-$testFileName] - } msg - if {$msg ne {}} { - PrintError "Problem renaming file: $msg" - } - } else { - # Print a message if there is a core file and (1) there - # previously wasn't one or (2) the new one is different - # from the old one. - - if {[info exists coreModTime]} { - if {$coreModTime != [file mtime \ - [file join [workingDirectory] core]]} { - puts [outputChannel] "A core file was created!" - } - } else { - puts [outputChannel] "A core file was created!" - } - } - } - } - flush [outputChannel] - flush [errorChannel] - return -} - -##################################################################### - -# Procs that determine which tests/test files to run - -# tcltest::GetMatchingFiles -# -# Looks at the patterns given to match and skip files and uses -# them to put together a list of the tests that will be run. -# -# Arguments: -# directory to search -# -# Results: -# The constructed list is returned to the user. This will -# primarily be used in 'all.tcl' files. It is used in -# runAllTests. -# -# Side Effects: -# None - -# a lower case version is needed for compatibility with tcltest 1.0 -proc tcltest::getMatchingFiles args {GetMatchingFiles {*}$args} - -proc tcltest::GetMatchingFiles { args } { - if {[llength $args]} { - set dirList $args - } else { - # Finding tests only in [testsDirectory] is normal operation. - # This procedure is written to accept multiple directory arguments - # only to satisfy version 1 compatibility. - set dirList [list [testsDirectory]] - } - - set matchingFiles [list] - foreach directory $dirList { - - # List files in $directory that match patterns to run. - set matchFileList [list] - foreach match [matchFiles] { - set matchFileList [concat $matchFileList \ - [glob -directory $directory -types {b c f p s} \ - -nocomplain -- $match]] - } - - # List files in $directory that match patterns to skip. - set skipFileList [list] - foreach skip [skipFiles] { - set skipFileList [concat $skipFileList \ - [glob -directory $directory -types {b c f p s} \ - -nocomplain -- $skip]] - } - - # Add to result list all files in match list and not in skip list - foreach file $matchFileList { - if {$file ni $skipFileList} { - lappend matchingFiles $file - } - } - } - - if {[llength $matchingFiles] == 0} { - PrintError "No test files remain after applying your match and\ - skip patterns!" - } - return $matchingFiles -} - -# tcltest::GetMatchingDirectories -- -# -# Looks at the patterns given to match and skip directories and -# uses them to put together a list of the test directories that we -# should attempt to run. (Only subdirectories containing an -# "all.tcl" file are put into the list.) -# -# Arguments: -# root directory from which to search -# -# Results: -# The constructed list is returned to the user. This is used in -# the primary all.tcl file. -# -# Side Effects: -# None. - -proc tcltest::GetMatchingDirectories {rootdir} { - - # Determine the skip list first, to avoid [glob]-ing over subdirectories - # we're going to throw away anyway. Be sure we skip the $rootdir if it - # comes up to avoid infinite loops. - set skipDirs [list $rootdir] - foreach pattern [skipDirectories] { - set skipDirs [concat $skipDirs [glob -directory $rootdir -types d \ - -nocomplain -- $pattern]] - } - - # Now step through the matching directories, prune out the skipped ones - # as you go. - set matchDirs [list] - foreach pattern [matchDirectories] { - foreach path [glob -directory $rootdir -types d -nocomplain -- \ - $pattern] { - if {$path ni $skipDirs} { - set matchDirs [concat $matchDirs [GetMatchingDirectories $path]] - if {[file exists [file join $path all.tcl]]} { - lappend matchDirs $path - } - } - } - } - - if {[llength $matchDirs] == 0} { - DebugPuts 1 "No test directories remain after applying match\ - and skip patterns!" - } - return [lsort $matchDirs] -} - -# tcltest::runAllTests -- -# -# prints output and sources test files according to the match and -# skip patterns provided. after sourcing test files, it goes on -# to source all.tcl files in matching test subdirectories. -# -# Arguments: -# shell being tested -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::runAllTests { {shell ""} } { - variable testSingleFile - variable numTestFiles - variable numTests - variable failFiles - variable DefaultValue - - FillFilesExisted - if {[llength [info level 0]] == 1} { - set shell [interpreter] - } - - set testSingleFile false - - puts [outputChannel] "Tests running in interp: $shell" - puts [outputChannel] "Tests located in: [testsDirectory]" - puts [outputChannel] "Tests running in: [workingDirectory]" - puts [outputChannel] "Temporary files stored in\ - [temporaryDirectory]" - - # [file system] first available in Tcl 8.4 - if {![catch {file system [testsDirectory]} result] - && ([lindex $result 0] ne "native")} { - # If we aren't running in the native filesystem, then we must - # run the tests in a single process (via 'source'), because - # trying to run then via a pipe will fail since the files don't - # really exist. - singleProcess 1 - } - - if {[singleProcess]} { - puts [outputChannel] \ - "Test files sourced into current interpreter" - } else { - puts [outputChannel] \ - "Test files run in separate interpreters" - } - if {[llength [skip]] > 0} { - puts [outputChannel] "Skipping tests that match: [skip]" - } - puts [outputChannel] "Running tests that match: [match]" - - if {[llength [skipFiles]] > 0} { - puts [outputChannel] \ - "Skipping test files that match: [skipFiles]" - } - if {[llength [matchFiles]] > 0} { - puts [outputChannel] \ - "Only running test files that match: [matchFiles]" - } - - set timeCmd {clock format [clock seconds]} - puts [outputChannel] "Tests began at [eval $timeCmd]" - - # Run each of the specified tests - foreach file [lsort [GetMatchingFiles]] { - set tail [file tail $file] - puts [outputChannel] $tail - flush [outputChannel] - - if {[singleProcess]} { - incr numTestFiles - uplevel 1 [list ::source $file] - } else { - # Pass along our configuration to the child processes. - # EXCEPT for the -outfile, because the parent process - # needs to read and process output of children. - set childargv [list] - foreach opt [Configure] { - if {$opt eq "-outfile"} {continue} - set value [Configure $opt] - # Don't bother passing default configuration options - if {$value eq $DefaultValue($opt)} { - continue - } - lappend childargv $opt $value - } - set cmd [linsert $childargv 0 | $shell $file] - if {[catch { - incr numTestFiles - set pipeFd [open $cmd "r"] - while {[gets $pipeFd line] >= 0} { - if {[regexp [join { - {^([^:]+):\t} - {Total\t([0-9]+)\t} - {Passed\t([0-9]+)\t} - {Skipped\t([0-9]+)\t} - {Failed\t([0-9]+)} - } ""] $line null testFile \ - Total Passed Skipped Failed]} { - foreach index {Total Passed Skipped Failed} { - incr numTests($index) [set $index] - } - if {$Failed > 0} { - lappend failFiles $testFile - } - } elseif {[regexp [join { - {^Number of tests skipped } - {for each constraint:} - {|^\t(\d+)\t(.+)$} - } ""] $line match skipped constraint]} { - if {[string match \t* $match]} { - AddToSkippedBecause $constraint $skipped - } - } else { - puts [outputChannel] $line - } - } - close $pipeFd - } msg]} { - puts [outputChannel] "Test file error: $msg" - # append the name of the test to a list to be reported - # later - lappend testFileFailures $file - } - } - } - - # cleanup - puts [outputChannel] "\nTests ended at [eval $timeCmd]" - cleanupTests 1 - if {[info exists testFileFailures]} { - puts [outputChannel] "\nTest files exiting with errors: \n" - foreach file $testFileFailures { - puts [outputChannel] " [file tail $file]\n" - } - } - - # Checking for subdirectories in which to run tests - foreach directory [GetMatchingDirectories [testsDirectory]] { - set dir [file tail $directory] - puts [outputChannel] [string repeat ~ 44] - puts [outputChannel] "$dir test began at [eval $timeCmd]\n" - - uplevel 1 [list ::source [file join $directory all.tcl]] - - set endTime [eval $timeCmd] - puts [outputChannel] "\n$dir test ended at $endTime" - puts [outputChannel] "" - puts [outputChannel] [string repeat ~ 44] - } - return -} - -##################################################################### - -# Test utility procs - not used in tcltest, but may be useful for -# testing. - -# tcltest::loadTestedCommands -- -# -# Uses the specified script to load the commands to test. Allowed to -# be empty, as the tested commands could have been compiled into the -# interpreter. -# -# Arguments -# none -# -# Results -# none -# -# Side Effects: -# none. - -proc tcltest::loadTestedCommands {} { - return [uplevel 1 [loadScript]] -} - -# tcltest::saveState -- -# -# Save information regarding what procs and variables exist. -# -# Arguments: -# none -# -# Results: -# Modifies the variable saveState -# -# Side effects: -# None. - -proc tcltest::saveState {} { - variable saveState - uplevel 1 [list ::set [namespace which -variable saveState]] \ - {[::list [::info procs] [::info vars]]} - DebugPuts 2 "[lindex [info level 0] 0]: $saveState" - return -} - -# tcltest::restoreState -- -# -# Remove procs and variables that didn't exist before the call to -# [saveState]. -# -# Arguments: -# none -# -# Results: -# Removes procs and variables from your environment if they don't -# exist in the saveState variable. -# -# Side effects: -# None. - -proc tcltest::restoreState {} { - variable saveState - foreach p [uplevel 1 {::info procs}] { - if {($p ni [lindex $saveState 0]) && ("[namespace current]::$p" ne - [uplevel 1 [list ::namespace origin $p]])} { - - DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p" - uplevel 1 [list ::catch [list ::rename $p {}]] - } - } - foreach p [uplevel 1 {::info vars}] { - if {$p ni [lindex $saveState 1]} { - DebugPuts 2 "[lindex [info level 0] 0]:\ - Removing variable $p" - uplevel 1 [list ::catch [list ::unset $p]] - } - } - return -} - -# tcltest::normalizeMsg -- -# -# Removes "extra" newlines from a string. -# -# Arguments: -# msg String to be modified -# -# Results: -# string with extra newlines removed -# -# Side effects: -# None. - -proc tcltest::normalizeMsg {msg} { - regsub "\n$" [string tolower $msg] "" msg - set msg [string map [list "\n\n" "\n"] $msg] - return [string map [list "\n\}" "\}"] $msg] -} - -# tcltest::makeFile -- -# -# Create a new file with the name <name>, and write <contents> to it. -# -# If this file hasn't been created via makeFile since the last time -# cleanupTests was called, add it to the $filesMade list, so it will be -# removed by the next call to cleanupTests. -# -# Arguments: -# contents content of the new file -# name name of the new file -# directory directory name for new file -# -# Results: -# absolute path to the file created -# -# Side effects: -# None. - -proc tcltest::makeFile {contents name {directory ""}} { - variable filesMade - FillFilesExisted - - if {[llength [info level 0]] == 3} { - set directory [temporaryDirectory] - } - - set fullName [file join $directory $name] - - DebugPuts 3 "[lindex [info level 0] 0]:\ - putting ``$contents'' into $fullName" - - set fd [open $fullName w] - chan configure $fd -translation lf - if {[string index $contents end] eq "\n"} { - puts -nonewline $fd $contents - } else { - puts $fd $contents - } - close $fd - - if {$fullName ni $filesMade} { - lappend filesMade $fullName - } - return $fullName -} - -# tcltest::removeFile -- -# -# Removes the named file from the filesystem -# -# Arguments: -# name file to be removed -# directory directory from which to remove file -# -# Results: -# return value from [file delete] -# -# Side effects: -# None. - -proc tcltest::removeFile {name {directory ""}} { - variable filesMade - FillFilesExisted - if {[llength [info level 0]] == 2} { - set directory [temporaryDirectory] - } - set fullName [file join $directory $name] - DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName" - set idx [lsearch -exact $filesMade $fullName] - set filesMade [lreplace $filesMade $idx $idx] - if {$idx == -1} { - DebugDo 1 { - Warn "removeFile removing \"$fullName\":\n not created by makeFile" - } - } - if {![file isfile $fullName]} { - DebugDo 1 { - Warn "removeFile removing \"$fullName\":\n not a file" - } - } - return [file delete -- $fullName] -} - -# tcltest::makeDirectory -- -# -# Create a new dir with the name <name>. -# -# If this dir hasn't been created via makeDirectory since the last time -# cleanupTests was called, add it to the $directoriesMade list, so it -# will be removed by the next call to cleanupTests. -# -# Arguments: -# name name of the new directory -# directory directory in which to create new dir -# -# Results: -# absolute path to the directory created -# -# Side effects: -# None. - -proc tcltest::makeDirectory {name {directory ""}} { - variable filesMade - FillFilesExisted - if {[llength [info level 0]] == 2} { - set directory [temporaryDirectory] - } - set fullName [file join $directory $name] - DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName" - file mkdir $fullName - if {$fullName ni $filesMade} { - lappend filesMade $fullName - } - return $fullName -} - -# tcltest::removeDirectory -- -# -# Removes a named directory from the file system. -# -# Arguments: -# name Name of the directory to remove -# directory Directory from which to remove -# -# Results: -# return value from [file delete] -# -# Side effects: -# None - -proc tcltest::removeDirectory {name {directory ""}} { - variable filesMade - FillFilesExisted - if {[llength [info level 0]] == 2} { - set directory [temporaryDirectory] - } - set fullName [file join $directory $name] - DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName" - set idx [lsearch -exact $filesMade $fullName] - set filesMade [lreplace $filesMade $idx $idx] - if {$idx == -1} { - DebugDo 1 { - Warn "removeDirectory removing \"$fullName\":\n not created\ - by makeDirectory" - } - } - if {![file isdirectory $fullName]} { - DebugDo 1 { - Warn "removeDirectory removing \"$fullName\":\n not a directory" - } - } - return [file delete -force -- $fullName] -} - -# tcltest::viewFile -- -# -# reads the content of a file and returns it -# -# Arguments: -# name of the file to read -# directory in which file is located -# -# Results: -# content of the named file -# -# Side effects: -# None. - -proc tcltest::viewFile {name {directory ""}} { - FillFilesExisted - if {[llength [info level 0]] == 2} { - set directory [temporaryDirectory] - } - set fullName [file join $directory $name] - set f [open $fullName] - set data [read -nonewline $f] - close $f - return $data -} - -# tcltest::bytestring -- -# -# Construct a string that consists of the requested sequence of bytes, -# as opposed to a string of properly formed UTF-8 characters. -# This allows the tester to -# 1. Create denormalized or improperly formed strings to pass to C -# procedures that are supposed to accept strings with embedded NULL -# bytes. -# 2. Confirm that a string result has a certain pattern of bytes, for -# instance to confirm that "\xe0\0" in a Tcl script is stored -# internally in UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80". -# -# Generally, it's a bad idea to examine the bytes in a Tcl string or to -# construct improperly formed strings in this manner, because it involves -# exposing that Tcl uses UTF-8 internally. -# -# Arguments: -# string being converted -# -# Results: -# result fom encoding -# -# Side effects: -# None - -proc tcltest::bytestring {string} { - return [encoding convertfrom identity $string] -} - -# tcltest::OpenFiles -- -# -# used in io tests, uses testchannel -# -# Arguments: -# None. -# -# Results: -# ??? -# -# Side effects: -# None. - -proc tcltest::OpenFiles {} { - if {[catch {testchannel open} result]} { - return {} - } - return $result -} - -# tcltest::LeakFiles -- -# -# used in io tests, uses testchannel -# -# Arguments: -# None. -# -# Results: -# ??? -# -# Side effects: -# None. - -proc tcltest::LeakFiles {old} { - if {[catch {testchannel open} new]} { - return {} - } - set leak {} - foreach p $new { - if {$p ni $old} { - lappend leak $p - } - } - return $leak -} - -# -# Internationalization / ISO support procs -- dl -# - -# tcltest::SetIso8859_1_Locale -- -# -# used in cmdIL.test, uses testlocale -# -# Arguments: -# None. -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::SetIso8859_1_Locale {} { - variable previousLocale - variable isoLocale - if {[info commands testlocale] != ""} { - set previousLocale [testlocale ctype] - testlocale ctype $isoLocale - } - return -} - -# tcltest::RestoreLocale -- -# -# used in cmdIL.test, uses testlocale -# -# Arguments: -# None. -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::RestoreLocale {} { - variable previousLocale - if {[info commands testlocale] != ""} { - testlocale ctype $previousLocale - } - return -} - -# tcltest::threadReap -- -# -# Kill all threads except for the main thread. -# Do nothing if testthread is not defined. -# -# Arguments: -# none. -# -# Results: -# Returns the number of existing threads. -# -# Side Effects: -# none. -# - -proc tcltest::threadReap {} { - if {[info commands testthread] ne {}} { - - # testthread built into tcltest - - testthread errorproc ThreadNullError - while {[llength [testthread names]] > 1} { - foreach tid [testthread names] { - if {$tid != [mainThread]} { - catch { - testthread send -async $tid {testthread exit} - } - } - } - ## Enter a bit a sleep to give the threads enough breathing - ## room to kill themselves off, otherwise the end up with a - ## massive queue of repeated events - after 1 - } - testthread errorproc ThreadError - return [llength [testthread names]] - } elseif {[info commands thread::id] ne {}} { - - # Thread extension - - thread::errorproc ThreadNullError - while {[llength [thread::names]] > 1} { - foreach tid [thread::names] { - if {$tid != [mainThread]} { - catch {thread::send -async $tid {thread::exit}} - } - } - ## Enter a bit a sleep to give the threads enough breathing - ## room to kill themselves off, otherwise the end up with a - ## massive queue of repeated events - after 1 - } - thread::errorproc ThreadError - return [llength [thread::names]] - } else { - return 1 - } - return 0 -} - -# Initialize the constraints and set up command line arguments -namespace eval tcltest { - # Define initializers for all the built-in contraint definitions - DefineConstraintInitializers - - # Set up the constraints in the testConstraints array to be lazily - # initialized by a registered initializer, or by "false" if no - # initializer is registered. - trace add variable testConstraints read [namespace code SafeFetch] - - # Only initialize constraints at package load time if an - # [initConstraintsHook] has been pre-defined. This is only - # for compatibility support. The modern way to add a custom - # test constraint is to just call the [testConstraint] command - # straight away, without all this "hook" nonsense. - if {[namespace current] eq - [namespace qualifiers [namespace which initConstraintsHook]]} { - InitConstraints - } else { - proc initConstraintsHook {} {} - } - - # Define the standard match commands - customMatch exact [list string equal] - customMatch glob [list string match] - customMatch regexp [list regexp --] - - # If the TCLTEST_OPTIONS environment variable exists, configure - # tcltest according to the option values it specifies. This has - # the effect of resetting tcltest's default configuration. - proc ConfigureFromEnvironment {} { - upvar #0 env(TCLTEST_OPTIONS) options - if {[catch {llength $options} msg]} { - Warn "invalid TCLTEST_OPTIONS \"$options\":\n invalid\ - Tcl list: $msg" - return - } - if {[llength $options] % 2} { - Warn "invalid TCLTEST_OPTIONS: \"$options\":\n should be\ - -option value ?-option value ...?" - return - } - if {[catch {Configure {*}$options} msg]} { - Warn "invalid TCLTEST_OPTIONS: \"$options\":\n $msg" - return - } - } - if {[info exists ::env(TCLTEST_OPTIONS)]} { - ConfigureFromEnvironment - } - - proc LoadTimeCmdLineArgParsingRequired {} { - set required false - if {[info exists ::argv] && ("-help" in $::argv)} { - # The command line asks for -help, so give it (and exit) - # right now. ([configure] does not process -help) - set required true - } - foreach hook { PrintUsageInfoHook processCmdLineArgsHook - processCmdLineArgsAddFlagsHook } { - if {[namespace current] eq - [namespace qualifiers [namespace which $hook]]} { - set required true - } else { - proc $hook args {} - } - } - return $required - } - - # Only initialize configurable options from the command line arguments - # at package load time if necessary for backward compatibility. This - # lets the tcltest user call [configure] for themselves if they wish. - # Traces are established for auto-configuration from the command line - # if any configurable options are accessed before the user calls - # [configure]. - if {[LoadTimeCmdLineArgParsingRequired]} { - ProcessCmdLineArgs - } else { - EstablishAutoConfigureTraces - } - - package provide [namespace tail [namespace current]] $Version -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8/8.6/http-2.8.12.tm b/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8/8.6/http-2.8.12.tm @@ -1,1584 +0,0 @@ -# http.tcl -- -# -# Client-side HTTP for GET, POST, and HEAD commands. These routines can -# be used in untrusted code that uses the Safesock security policy. -# These procedures use a callback interface to avoid using vwait, which -# is not defined in the safe base. -# -# See the file "license.terms" for information on usage and redistribution of -# this file, and for a DISCLAIMER OF ALL WARRANTIES. - -package require Tcl 8.6- -# Keep this in sync with pkgIndex.tcl and with the install directories in -# Makefiles -package provide http 2.8.12 - -namespace eval http { - # Allow resourcing to not clobber existing data - - variable http - if {![info exists http]} { - array set http { - -accept */* - -proxyhost {} - -proxyport {} - -proxyfilter http::ProxyRequired - -urlencoding utf-8 - } - # We need a useragent string of this style or various servers will refuse to - # send us compressed content even when we ask for it. This follows the - # de-facto layout of user-agent strings in current browsers. - # Safe interpreters do not have ::tcl_platform(os) or - # ::tcl_platform(osVersion). - if {[interp issafe]} { - set http(-useragent) "Mozilla/5.0\ - (Windows; U;\ - Windows NT 10.0)\ - http/[package provide http] Tcl/[package provide Tcl]" - } else { - set http(-useragent) "Mozilla/5.0\ - ([string totitle $::tcl_platform(platform)]; U;\ - $::tcl_platform(os) $::tcl_platform(osVersion))\ - http/[package provide http] Tcl/[package provide Tcl]" - } - } - - proc init {} { - # Set up the map for quoting chars. RFC3986 Section 2.3 say percent - # encode all except: "... percent-encoded octets in the ranges of - # ALPHA (%41-%5A and %61-%7A), DIGIT (%30-%39), hyphen (%2D), period - # (%2E), underscore (%5F), or tilde (%7E) should not be created by URI - # producers ..." - for {set i 0} {$i <= 256} {incr i} { - set c [format %c $i] - if {![string match {[-._~a-zA-Z0-9]} $c]} { - set map($c) %[format %.2X $i] - } - } - # These are handled specially - set map(\n) %0D%0A - variable formMap [array get map] - - # Create a map for HTTP/1.1 open sockets - variable socketmap - if {[info exists socketmap]} { - # Close but don't remove open sockets on re-init - foreach {url sock} [array get socketmap] { - catch {close $sock} - } - } - array set socketmap {} - } - init - - variable urlTypes - if {![info exists urlTypes]} { - set urlTypes(http) [list 80 ::socket] - } - - variable encodings [string tolower [encoding names]] - # This can be changed, but iso8859-1 is the RFC standard. - variable defaultCharset - if {![info exists defaultCharset]} { - set defaultCharset "iso8859-1" - } - - # Force RFC 3986 strictness in geturl url verification? - variable strict - if {![info exists strict]} { - set strict 1 - } - - # Let user control default keepalive for compatibility - variable defaultKeepalive - if {![info exists defaultKeepalive]} { - set defaultKeepalive 0 - } - - namespace export geturl config reset wait formatQuery register unregister - # Useful, but not exported: data size status code -} - -# http::Log -- -# -# Debugging output -- define this to observe HTTP/1.1 socket usage. -# Should echo any args received. -# -# Arguments: -# msg Message to output -# -if {[info command http::Log] eq {}} {proc http::Log {args} {}} - -# http::register -- -# -# See documentation for details. -# -# Arguments: -# proto URL protocol prefix, e.g. https -# port Default port for protocol -# command Command to use to create socket -# Results: -# list of port and command that was registered. - -proc http::register {proto port command} { - variable urlTypes - set urlTypes([string tolower $proto]) [list $port $command] -} - -# http::unregister -- -# -# Unregisters URL protocol handler -# -# Arguments: -# proto URL protocol prefix, e.g. https -# Results: -# list of port and command that was unregistered. - -proc http::unregister {proto} { - variable urlTypes - set lower [string tolower $proto] - if {![info exists urlTypes($lower)]} { - return -code error "unsupported url type \"$proto\"" - } - set old $urlTypes($lower) - unset urlTypes($lower) - return $old -} - -# http::config -- -# -# See documentation for details. -# -# Arguments: -# args Options parsed by the procedure. -# Results: -# TODO - -proc http::config {args} { - variable http - set options [lsort [array names http -*]] - set usage [join $options ", "] - if {[llength $args] == 0} { - set result {} - foreach name $options { - lappend result $name $http($name) - } - return $result - } - set options [string map {- ""} $options] - set pat ^-(?:[join $options |])$ - if {[llength $args] == 1} { - set flag [lindex $args 0] - if {![regexp -- $pat $flag]} { - return -code error "Unknown option $flag, must be: $usage" - } - return $http($flag) - } else { - foreach {flag value} $args { - if {![regexp -- $pat $flag]} { - return -code error "Unknown option $flag, must be: $usage" - } - set http($flag) $value - } - } -} - -# http::Finish -- -# -# Clean up the socket and eval close time callbacks -# -# Arguments: -# token Connection token. -# errormsg (optional) If set, forces status to error. -# skipCB (optional) If set, don't call the -command callback. This -# is useful when geturl wants to throw an exception instead -# of calling the callback. That way, the same error isn't -# reported to two places. -# -# Side Effects: -# Closes the socket - -proc http::Finish {token {errormsg ""} {skipCB 0}} { - variable $token - upvar 0 $token state - global errorInfo errorCode - if {$errormsg ne ""} { - set state(error) [list $errormsg $errorInfo $errorCode] - set state(status) "error" - } - if { ($state(status) eq "timeout") - || ($state(status) eq "error") - || ([info exists state(-keepalive)] && !$state(-keepalive)) - || ([info exists state(connection)] && ($state(connection) eq "close")) - } { - CloseSocket $state(sock) $token - } - if {[info exists state(after)]} { - after cancel $state(after) - } - if {[info exists state(-command)] && !$skipCB - && ![info exists state(done-command-cb)]} { - set state(done-command-cb) yes - if {[catch {eval $state(-command) {$token}} err] && $errormsg eq ""} { - set state(error) [list $err $errorInfo $errorCode] - set state(status) error - } - } -} - -# http::CloseSocket - -# -# Close a socket and remove it from the persistent sockets table. If -# possible an http token is included here but when we are called from a -# fileevent on remote closure we need to find the correct entry - hence -# the second section. - -proc ::http::CloseSocket {s {token {}}} { - variable socketmap - catch {fileevent $s readable {}} - set conn_id {} - if {$token ne ""} { - variable $token - upvar 0 $token state - if {[info exists state(socketinfo)]} { - set conn_id $state(socketinfo) - } - } else { - set map [array get socketmap] - set ndx [lsearch -exact $map $s] - if {$ndx != -1} { - incr ndx -1 - set conn_id [lindex $map $ndx] - } - } - if {$conn_id eq {} || ![info exists socketmap($conn_id)]} { - Log "Closing socket $s (no connection info)" - if {[catch {close $s} err]} { - Log "Error: $err" - } - } else { - if {[info exists socketmap($conn_id)]} { - Log "Closing connection $conn_id (sock $socketmap($conn_id))" - if {[catch {close $socketmap($conn_id)} err]} { - Log "Error: $err" - } - unset socketmap($conn_id) - } else { - Log "Cannot close connection $conn_id - no socket in socket map" - } - } -} - -# http::reset -- -# -# See documentation for details. -# -# Arguments: -# token Connection token. -# why Status info. -# -# Side Effects: -# See Finish - -proc http::reset {token {why reset}} { - variable $token - upvar 0 $token state - set state(status) $why - catch {fileevent $state(sock) readable {}} - catch {fileevent $state(sock) writable {}} - Finish $token - if {[info exists state(error)]} { - set errorlist $state(error) - unset state - eval ::error $errorlist - } -} - -# http::geturl -- -# -# Establishes a connection to a remote url via http. -# -# Arguments: -# url The http URL to goget. -# args Option value pairs. Valid options include: -# -blocksize, -validate, -headers, -timeout -# Results: -# Returns a token for this connection. This token is the name of an -# array that the caller should unset to garbage collect the state. - -proc http::geturl {url args} { - variable http - variable urlTypes - variable defaultCharset - variable defaultKeepalive - variable strict - - # Initialize the state variable, an array. We'll return the name of this - # array as the token for the transaction. - - if {![info exists http(uid)]} { - set http(uid) 0 - } - set token [namespace current]::[incr http(uid)] - variable $token - upvar 0 $token state - reset $token - - # Process command options. - - array set state { - -binary false - -blocksize 8192 - -queryblocksize 8192 - -validate 0 - -headers {} - -timeout 0 - -type application/x-www-form-urlencoded - -queryprogress {} - -protocol 1.1 - binary 0 - state connecting - meta {} - coding {} - currentsize 0 - totalsize 0 - querylength 0 - queryoffset 0 - type text/html - body {} - status "" - http "" - connection close - } - set state(-keepalive) $defaultKeepalive - set state(-strict) $strict - # These flags have their types verified [Bug 811170] - array set type { - -binary boolean - -blocksize integer - -queryblocksize integer - -strict boolean - -timeout integer - -validate boolean - } - set state(charset) $defaultCharset - set options { - -binary -blocksize -channel -command -handler -headers -keepalive - -method -myaddr -progress -protocol -query -queryblocksize - -querychannel -queryprogress -strict -timeout -type -validate - } - set usage [join [lsort $options] ", "] - set options [string map {- ""} $options] - set pat ^-(?:[join $options |])$ - foreach {flag value} $args { - if {[regexp -- $pat $flag]} { - # Validate numbers - if { - [info exists type($flag)] && - ![string is $type($flag) -strict $value] - } { - unset $token - return -code error \ - "Bad value for $flag ($value), must be $type($flag)" - } - set state($flag) $value - } else { - unset $token - return -code error "Unknown option $flag, can be: $usage" - } - } - - # Make sure -query and -querychannel aren't both specified - - set isQueryChannel [info exists state(-querychannel)] - set isQuery [info exists state(-query)] - if {$isQuery && $isQueryChannel} { - unset $token - return -code error "Can't combine -query and -querychannel options!" - } - - # Validate URL, determine the server host and port, and check proxy case - # Recognize user:pass@host URLs also, although we do not do anything with - # that info yet. - - # URLs have basically four parts. - # First, before the colon, is the protocol scheme (e.g. http) - # Second, for HTTP-like protocols, is the authority - # The authority is preceded by // and lasts up to (but not including) - # the following / or ? and it identifies up to four parts, of which - # only one, the host, is required (if an authority is present at all). - # All other parts of the authority (user name, password, port number) - # are optional. - # Third is the resource name, which is split into two parts at a ? - # The first part (from the single "/" up to "?") is the path, and the - # second part (from that "?" up to "#") is the query. *HOWEVER*, we do - # not need to separate them; we send the whole lot to the server. - # Both, path and query are allowed to be missing, including their - # delimiting character. - # Fourth is the fragment identifier, which is everything after the first - # "#" in the URL. The fragment identifier MUST NOT be sent to the server - # and indeed, we don't bother to validate it (it could be an error to - # pass it in here, but it's cheap to strip). - # - # An example of a URL that has all the parts: - # - # http://jschmoe:xyzzy@www.bogus.net:8000/foo/bar.tml?q=foo#changes - # - # The "http" is the protocol, the user is "jschmoe", the password is - # "xyzzy", the host is "www.bogus.net", the port is "8000", the path is - # "/foo/bar.tml", the query is "q=foo", and the fragment is "changes". - # - # Note that the RE actually combines the user and password parts, as - # recommended in RFC 3986. Indeed, that RFC states that putting passwords - # in URLs is a Really Bad Idea, something with which I would agree utterly. - # - # From a validation perspective, we need to ensure that the parts of the - # URL that are going to the server are correctly encoded. This is only - # done if $state(-strict) is true (inherited from $::http::strict). - - set URLmatcher {(?x) # this is _expanded_ syntax - ^ - (?: (\w+) : ) ? # <protocol scheme> - (?: // - (?: - ( - [^@/\#?]+ # <userinfo part of authority> - ) @ - )? - ( # <host part of authority> - [^/:\#?]+ | # host name or IPv4 address - \[ [^/\#?]+ \] # IPv6 address in square brackets - ) - (?: : (\d+) )? # <port part of authority> - )? - ( [/\?] [^\#]*)? # <path> (including query) - (?: \# (.*) )? # <fragment> - $ - } - - # Phase one: parse - if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} { - unset $token - return -code error "Unsupported URL: $url" - } - # Phase two: validate - set host [string trim $host {[]}]; # strip square brackets from IPv6 address - if {$host eq ""} { - # Caller has to provide a host name; we do not have a "default host" - # that would enable us to handle relative URLs. - unset $token - return -code error "Missing host part: $url" - # Note that we don't check the hostname for validity here; if it's - # invalid, we'll simply fail to resolve it later on. - } - if {$port ne "" && $port > 65535} { - unset $token - return -code error "Invalid port number: $port" - } - # The user identification and resource identification parts of the URL can - # have encoded characters in them; take care! - if {$user ne ""} { - # Check for validity according to RFC 3986, Appendix A - set validityRE {(?xi) - ^ - (?: [-\w.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+ - $ - } - if {$state(-strict) && ![regexp -- $validityRE $user]} { - unset $token - # Provide a better error message in this error case - if {[regexp {(?i)%(?![0-9a-f][0-9a-f]).?.?} $user bad]} { - return -code error \ - "Illegal encoding character usage \"$bad\" in URL user" - } - return -code error "Illegal characters in URL user" - } - } - if {$srvurl ne ""} { - # RFC 3986 allows empty paths (not even a /), but servers - # return 400 if the path in the HTTP request doesn't start - # with / , so add it here if needed. - if {[string index $srvurl 0] ne "/"} { - set srvurl /$srvurl - } - # Check for validity according to RFC 3986, Appendix A - set validityRE {(?xi) - ^ - # Path part (already must start with / character) - (?: [-\w.~!$&'()*+,;=:@/] | %[0-9a-f][0-9a-f] )* - # Query part (optional, permits ? characters) - (?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )? - $ - } - if {$state(-strict) && ![regexp -- $validityRE $srvurl]} { - unset $token - # Provide a better error message in this error case - if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} { - return -code error \ - "Illegal encoding character usage \"$bad\" in URL path" - } - return -code error "Illegal characters in URL path" - } - } else { - set srvurl / - } - if {$proto eq ""} { - set proto http - } - set lower [string tolower $proto] - if {![info exists urlTypes($lower)]} { - unset $token - return -code error "Unsupported URL type \"$proto\"" - } - set defport [lindex $urlTypes($lower) 0] - set defcmd [lindex $urlTypes($lower) 1] - - if {$port eq ""} { - set port $defport - } - if {![catch {$http(-proxyfilter) $host} proxy]} { - set phost [lindex $proxy 0] - set pport [lindex $proxy 1] - } - - # OK, now reassemble into a full URL - set url ${proto}:// - if {$user ne ""} { - append url $user - append url @ - } - append url $host - if {$port != $defport} { - append url : $port - } - append url $srvurl - # Don't append the fragment! - set state(url) $url - - # If a timeout is specified we set up the after event and arrange for an - # asynchronous socket connection. - - set sockopts [list -async] - if {$state(-timeout) > 0} { - set state(after) [after $state(-timeout) \ - [list http::reset $token timeout]] - } - - # If we are using the proxy, we must pass in the full URL that includes - # the server name. - - if {[info exists phost] && ($phost ne "")} { - set srvurl $url - set targetAddr [list $phost $pport] - } else { - set targetAddr [list $host $port] - } - # Proxy connections aren't shared among different hosts. - set state(socketinfo) $host:$port - - # Save the accept types at this point to prevent a race condition. [Bug - # c11a51c482] - set state(accept-types) $http(-accept) - - # See if we are supposed to use a previously opened channel. - if {$state(-keepalive)} { - variable socketmap - if {[info exists socketmap($state(socketinfo))]} { - if {[catch {fconfigure $socketmap($state(socketinfo))}]} { - Log "WARNING: socket for $state(socketinfo) was closed" - unset socketmap($state(socketinfo)) - } else { - set sock $socketmap($state(socketinfo)) - Log "reusing socket $sock for $state(socketinfo)" - catch {fileevent $sock writable {}} - catch {fileevent $sock readable {}} - } - } - # don't automatically close this connection socket - set state(connection) {} - } - if {![info exists sock]} { - # Pass -myaddr directly to the socket command - if {[info exists state(-myaddr)]} { - lappend sockopts -myaddr $state(-myaddr) - } - if {[catch {eval $defcmd $sockopts $targetAddr} sock]} { - # something went wrong while trying to establish the connection. - # Clean up after events and such, but DON'T call the command - # callback (if available) because we're going to throw an - # exception from here instead. - - set state(sock) $sock - Finish $token "" 1 - cleanup $token - return -code error $sock - } - } - set state(sock) $sock - Log "Using $sock for $state(socketinfo)" \ - [expr {$state(-keepalive)?"keepalive":""}] - if {$state(-keepalive)} { - set socketmap($state(socketinfo)) $sock - } - - if {![info exists phost]} { - set phost "" - } - fileevent $sock writable [list http::Connect $token $proto $phost $srvurl] - - # Wait for the connection to complete. - if {![info exists state(-command)]} { - # geturl does EVERYTHING asynchronously, so if the user - # calls it synchronously, we just do a wait here. - http::wait $token - - if {![info exists state]} { - # If we timed out then Finish has been called and the users - # command callback may have cleaned up the token. If so we end up - # here with nothing left to do. - return $token - } elseif {$state(status) eq "error"} { - # Something went wrong while trying to establish the connection. - # Clean up after events and such, but DON'T call the command - # callback (if available) because we're going to throw an - # exception from here instead. - set err [lindex $state(error) 0] - cleanup $token - return -code error $err - } - } - - return $token -} - -# http::Connected -- -# -# Callback used when the connection to the HTTP server is actually -# established. -# -# Arguments: -# token State token. -# proto What protocol (http, https, etc.) was used to connect. -# phost Are we using keep-alive? Non-empty if yes. -# srvurl Service-local URL that we're requesting -# Results: -# None. - -proc http::Connected {token proto phost srvurl} { - variable http - variable urlTypes - - variable $token - upvar 0 $token state - - # Set back the variables needed here - set sock $state(sock) - set isQueryChannel [info exists state(-querychannel)] - set isQuery [info exists state(-query)] - set host [lindex [split $state(socketinfo) :] 0] - set port [lindex [split $state(socketinfo) :] 1] - - set lower [string tolower $proto] - set defport [lindex $urlTypes($lower) 0] - - # Send data in cr-lf format, but accept any line terminators - - fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize) - - # The following is disallowed in safe interpreters, but the socket is - # already in non-blocking mode in that case. - - catch {fconfigure $sock -blocking off} - set how GET - if {$isQuery} { - set state(querylength) [string length $state(-query)] - if {$state(querylength) > 0} { - set how POST - set contDone 0 - } else { - # There's no query data. - unset state(-query) - set isQuery 0 - } - } elseif {$state(-validate)} { - set how HEAD - } elseif {$isQueryChannel} { - set how POST - # The query channel must be blocking for the async Write to - # work properly. - fconfigure $state(-querychannel) -blocking 1 -translation binary - set contDone 0 - } - if {[info exists state(-method)] && $state(-method) ne ""} { - set how $state(-method) - } - # We cannot handle chunked encodings with -handler, so force HTTP/1.0 - # until we can manage this. - if {[info exists state(-handler)]} { - set state(-protocol) 1.0 - } - set accept_types_seen 0 - if {[catch { - puts $sock "$how $srvurl HTTP/$state(-protocol)" - if {[dict exists $state(-headers) Host]} { - # Allow Host spoofing. [Bug 928154] - puts $sock "Host: [dict get $state(-headers) Host]" - } elseif {$port == $defport} { - # Don't add port in this case, to handle broken servers. [Bug - # #504508] - puts $sock "Host: $host" - } else { - puts $sock "Host: $host:$port" - } - puts $sock "User-Agent: $http(-useragent)" - if {$state(-protocol) == 1.0 && $state(-keepalive)} { - puts $sock "Connection: keep-alive" - } - if {$state(-protocol) > 1.0 && !$state(-keepalive)} { - puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1 - } - if {[info exists phost] && ($phost ne "") && $state(-keepalive)} { - puts $sock "Proxy-Connection: Keep-Alive" - } - set accept_encoding_seen 0 - set content_type_seen 0 - dict for {key value} $state(-headers) { - set value [string map [list \n "" \r ""] $value] - set key [string map {" " -} [string trim $key]] - if {[string equal -nocase $key "host"]} { - continue - } - if {[string equal -nocase $key "accept-encoding"]} { - set accept_encoding_seen 1 - } - if {[string equal -nocase $key "accept"]} { - set accept_types_seen 1 - } - if {[string equal -nocase $key "content-type"]} { - set content_type_seen 1 - } - if {[string equal -nocase $key "content-length"]} { - set contDone 1 - set state(querylength) $value - } - if {[string length $key]} { - puts $sock "$key: $value" - } - } - # Allow overriding the Accept header on a per-connection basis. Useful - # for working with REST services. [Bug c11a51c482] - if {!$accept_types_seen} { - puts $sock "Accept: $state(accept-types)" - } - if {!$accept_encoding_seen && ![info exists state(-handler)]} { - puts $sock "Accept-Encoding: gzip,deflate,compress" - } - if {$isQueryChannel && $state(querylength) == 0} { - # Try to determine size of data in channel. If we cannot seek, the - # surrounding catch will trap us - - set start [tell $state(-querychannel)] - seek $state(-querychannel) 0 end - set state(querylength) \ - [expr {[tell $state(-querychannel)] - $start}] - seek $state(-querychannel) $start - } - - # Flush the request header and set up the fileevent that will either - # push the POST data or read the response. - # - # fileevent note: - # - # It is possible to have both the read and write fileevents active at - # this point. The only scenario it seems to affect is a server that - # closes the connection without reading the POST data. (e.g., early - # versions TclHttpd in various error cases). Depending on the - # platform, the client may or may not be able to get the response from - # the server because of the error it will get trying to write the post - # data. Having both fileevents active changes the timing and the - # behavior, but no two platforms (among Solaris, Linux, and NT) behave - # the same, and none behave all that well in any case. Servers should - # always read their POST data if they expect the client to read their - # response. - - if {$isQuery || $isQueryChannel} { - if {!$content_type_seen} { - puts $sock "Content-Type: $state(-type)" - } - if {!$contDone} { - puts $sock "Content-Length: $state(querylength)" - } - puts $sock "" - fconfigure $sock -translation {auto binary} - fileevent $sock writable [list http::Write $token] - } else { - puts $sock "" - flush $sock - fileevent $sock readable [list http::Event $sock $token] - } - - } err]} { - # The socket probably was never connected, or the connection dropped - # later. - - # if state(status) is error, it means someone's already called Finish - # to do the above-described clean up. - if {$state(status) ne "error"} { - Finish $token $err - } - } -} - -# Data access functions: -# Data - the URL data -# Status - the transaction status: ok, reset, eof, timeout -# Code - the HTTP transaction code, e.g., 200 -# Size - the size of the URL data - -proc http::data {token} { - variable $token - upvar 0 $token state - return $state(body) -} -proc http::status {token} { - if {![info exists $token]} { - return "error" - } - variable $token - upvar 0 $token state - return $state(status) -} -proc http::code {token} { - variable $token - upvar 0 $token state - return $state(http) -} -proc http::ncode {token} { - variable $token - upvar 0 $token state - if {[regexp {[0-9]{3}} $state(http) numeric_code]} { - return $numeric_code - } else { - return $state(http) - } -} -proc http::size {token} { - variable $token - upvar 0 $token state - return $state(currentsize) -} -proc http::meta {token} { - variable $token - upvar 0 $token state - return $state(meta) -} -proc http::error {token} { - variable $token - upvar 0 $token state - if {[info exists state(error)]} { - return $state(error) - } - return "" -} - -# http::cleanup -# -# Garbage collect the state associated with a transaction -# -# Arguments -# token The token returned from http::geturl -# -# Side Effects -# unsets the state array - -proc http::cleanup {token} { - variable $token - upvar 0 $token state - if {[info exists state]} { - unset state - } -} - -# http::Connect -# -# This callback is made when an asyncronous connection completes. -# -# Arguments -# token The token returned from http::geturl -# -# Side Effects -# Sets the status of the connection, which unblocks -# the waiting geturl call - -proc http::Connect {token proto phost srvurl} { - variable $token - upvar 0 $token state - set err "due to unexpected EOF" - if { - [eof $state(sock)] || - [set err [fconfigure $state(sock) -error]] ne "" - } { - Finish $token "connect failed $err" - } else { - fileevent $state(sock) writable {} - ::http::Connected $token $proto $phost $srvurl - } - return -} - -# http::Write -# -# Write POST query data to the socket -# -# Arguments -# token The token for the connection -# -# Side Effects -# Write the socket and handle callbacks. - -proc http::Write {token} { - variable $token - upvar 0 $token state - set sock $state(sock) - - # Output a block. Tcl will buffer this if the socket blocks - set done 0 - if {[catch { - # Catch I/O errors on dead sockets - - if {[info exists state(-query)]} { - # Chop up large query strings so queryprogress callback can give - # smooth feedback. - - puts -nonewline $sock \ - [string range $state(-query) $state(queryoffset) \ - [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]] - incr state(queryoffset) $state(-queryblocksize) - if {$state(queryoffset) >= $state(querylength)} { - set state(queryoffset) $state(querylength) - set done 1 - } - } else { - # Copy blocks from the query channel - - set outStr [read $state(-querychannel) $state(-queryblocksize)] - puts -nonewline $sock $outStr - incr state(queryoffset) [string length $outStr] - if {[eof $state(-querychannel)]} { - set done 1 - } - } - } err]} { - # Do not call Finish here, but instead let the read half of the socket - # process whatever server reply there is to get. - - set state(posterror) $err - set done 1 - } - if {$done} { - catch {flush $sock} - fileevent $sock writable {} - fileevent $sock readable [list http::Event $sock $token] - } - - # Callback to the client after we've completely handled everything. - - if {[string length $state(-queryprogress)]} { - eval $state(-queryprogress) \ - [list $token $state(querylength) $state(queryoffset)] - } -} - -# http::Event -# -# Handle input on the socket -# -# Arguments -# sock The socket receiving input. -# token The token returned from http::geturl -# -# Side Effects -# Read the socket and handle callbacks. - -proc http::Event {sock token} { - variable $token - upvar 0 $token state - - if {![info exists state]} { - Log "Event $sock with invalid token '$token' - remote close?" - if {![eof $sock]} { - if {[set d [read $sock]] ne ""} { - Log "WARNING: additional data left on closed socket" - } - } - CloseSocket $sock - return - } - if {$state(state) eq "connecting"} { - if {[catch {gets $sock state(http)} n]} { - return [Finish $token $n] - } elseif {$n >= 0} { - set state(state) "header" - } - } elseif {$state(state) eq "header"} { - if {[catch {gets $sock line} n]} { - return [Finish $token $n] - } elseif {$n == 0} { - # We have now read all headers - # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3 - if {$state(http) == "" || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100)} { - set state(state) "connecting" - return - } - - set state(state) body - - # If doing a HEAD, then we won't get any body - if {$state(-validate)} { - Eof $token - return - } - - # For non-chunked transfer we may have no body - in this case we - # may get no further file event if the connection doesn't close - # and no more data is sent. We can tell and must finish up now - - # not later. - if { - !(([info exists state(connection)] - && ($state(connection) eq "close")) - || [info exists state(transfer)]) - && ($state(totalsize) == 0) - } { - Log "body size is 0 and no events likely - complete." - Eof $token - return - } - - # We have to use binary translation to count bytes properly. - fconfigure $sock -translation binary - - if { - $state(-binary) || [IsBinaryContentType $state(type)] - } { - # Turn off conversions for non-text data - set state(binary) 1 - } - if {[info exists state(-channel)]} { - if {$state(binary) || [llength [ContentEncoding $token]]} { - fconfigure $state(-channel) -translation binary - } - if {![info exists state(-handler)]} { - # Initiate a sequence of background fcopies - fileevent $sock readable {} - CopyStart $sock $token - return - } - } - } elseif {$n > 0} { - # Process header lines - if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { - switch -- [string tolower $key] { - content-type { - set state(type) [string trim [string tolower $value]] - # grab the optional charset information - if {[regexp -nocase \ - {charset\s*=\s*\"((?:[^""]|\\\")*)\"} \ - $state(type) -> cs]} { - set state(charset) [string map {{\"} \"} $cs] - } else { - regexp -nocase {charset\s*=\s*(\S+?);?} \ - $state(type) -> state(charset) - } - } - content-length { - set state(totalsize) [string trim $value] - } - content-encoding { - set state(coding) [string trim $value] - } - transfer-encoding { - set state(transfer) \ - [string trim [string tolower $value]] - } - proxy-connection - - connection { - set state(connection) \ - [string trim [string tolower $value]] - } - } - lappend state(meta) $key [string trim $value] - } - } - } else { - # Now reading body - if {[catch { - if {[info exists state(-handler)]} { - set n [eval $state(-handler) [list $sock $token]] - } elseif {[info exists state(transfer_final)]} { - set line [getTextLine $sock] - set n [string length $line] - if {$n > 0} { - Log "found $n bytes following final chunk" - append state(transfer_final) $line - } else { - Log "final chunk part" - Eof $token - } - } elseif { - [info exists state(transfer)] - && $state(transfer) eq "chunked" - } { - set size 0 - set chunk [getTextLine $sock] - set n [string length $chunk] - if {[string trim $chunk] ne ""} { - scan $chunk %x size - if {$size != 0} { - set bl [fconfigure $sock -blocking] - fconfigure $sock -blocking 1 - set chunk [read $sock $size] - fconfigure $sock -blocking $bl - set n [string length $chunk] - if {$n >= 0} { - append state(body) $chunk - } - if {$size != [string length $chunk]} { - Log "WARNING: mis-sized chunk:\ - was [string length $chunk], should be $size" - } - getTextLine $sock - } else { - set state(transfer_final) {} - } - } - } else { - #Log "read non-chunk $state(currentsize) of $state(totalsize)" - set block [read $sock $state(-blocksize)] - set n [string length $block] - if {$n >= 0} { - append state(body) $block - } - } - if {[info exists state]} { - if {$n >= 0} { - incr state(currentsize) $n - } - # If Content-Length - check for end of data. - if { - ($state(totalsize) > 0) - && ($state(currentsize) >= $state(totalsize)) - } { - Eof $token - } - } - } err]} { - return [Finish $token $err] - } else { - if {[info exists state(-progress)]} { - eval $state(-progress) \ - [list $token $state(totalsize) $state(currentsize)] - } - } - } - - # catch as an Eof above may have closed the socket already - if {![catch {eof $sock} eof] && $eof} { - if {[info exists $token]} { - set state(connection) close - Eof $token - } else { - # open connection closed on a token that has been cleaned up. - CloseSocket $sock - } - return - } -} - -# http::IsBinaryContentType -- -# -# Determine if the content-type means that we should definitely transfer -# the data as binary. [Bug 838e99a76d] -# -# Arguments -# type The content-type of the data. -# -# Results: -# Boolean, true if we definitely should be binary. - -proc http::IsBinaryContentType {type} { - lassign [split [string tolower $type] "/;"] major minor - if {$major eq "text"} { - return false - } - # There's a bunch of XML-as-application-format things about. See RFC 3023 - # and so on. - if {$major eq "application"} { - set minor [string trimright $minor] - if {$minor in {"xml" "xml-external-parsed-entity" "xml-dtd"}} { - return false - } - } - # Not just application/foobar+xml but also image/svg+xml, so let us not - # restrict things for now... - if {[string match "*+xml" $minor]} { - return false - } - return true -} - -# http::getTextLine -- -# -# Get one line with the stream in blocking crlf mode -# -# Arguments -# sock The socket receiving input. -# -# Results: -# The line of text, without trailing newline - -proc http::getTextLine {sock} { - set tr [fconfigure $sock -translation] - set bl [fconfigure $sock -blocking] - fconfigure $sock -translation crlf -blocking 1 - set r [gets $sock] - fconfigure $sock -translation $tr -blocking $bl - return $r -} - -# http::CopyStart -# -# Error handling wrapper around fcopy -# -# Arguments -# sock The socket to copy from -# token The token returned from http::geturl -# -# Side Effects -# This closes the connection upon error - -proc http::CopyStart {sock token {initial 1}} { - upvar #0 $token state - if {[info exists state(transfer)] && $state(transfer) eq "chunked"} { - foreach coding [ContentEncoding $token] { - lappend state(zlib) [zlib stream $coding] - } - make-transformation-chunked $sock [namespace code [list CopyChunk $token]] - } else { - if {$initial} { - foreach coding [ContentEncoding $token] { - zlib push $coding $sock - } - } - if {[catch { - fcopy $sock $state(-channel) -size $state(-blocksize) -command \ - [list http::CopyDone $token] - } err]} { - Finish $token $err - } - } -} - -proc http::CopyChunk {token chunk} { - upvar 0 $token state - if {[set count [string length $chunk]]} { - incr state(currentsize) $count - if {[info exists state(zlib)]} { - foreach stream $state(zlib) { - set chunk [$stream add $chunk] - } - } - puts -nonewline $state(-channel) $chunk - if {[info exists state(-progress)]} { - eval [linsert $state(-progress) end \ - $token $state(totalsize) $state(currentsize)] - } - } else { - Log "CopyChunk Finish $token" - if {[info exists state(zlib)]} { - set excess "" - foreach stream $state(zlib) { - catch {set excess [$stream add -finalize $excess]} - } - puts -nonewline $state(-channel) $excess - foreach stream $state(zlib) { $stream close } - unset state(zlib) - } - Eof $token ;# FIX ME: pipelining. - } -} - -# http::CopyDone -# -# fcopy completion callback -# -# Arguments -# token The token returned from http::geturl -# count The amount transfered -# -# Side Effects -# Invokes callbacks - -proc http::CopyDone {token count {error {}}} { - variable $token - upvar 0 $token state - set sock $state(sock) - incr state(currentsize) $count - if {[info exists state(-progress)]} { - eval $state(-progress) \ - [list $token $state(totalsize) $state(currentsize)] - } - # At this point the token may have been reset - if {[string length $error]} { - Finish $token $error - } elseif {[catch {eof $sock} iseof] || $iseof} { - Eof $token - } else { - CopyStart $sock $token 0 - } -} - -# http::Eof -# -# Handle eof on the socket -# -# Arguments -# token The token returned from http::geturl -# -# Side Effects -# Clean up the socket - -proc http::Eof {token {force 0}} { - variable $token - upvar 0 $token state - if {$state(state) eq "header"} { - # Premature eof - set state(status) eof - } else { - set state(status) ok - } - - if {[string length $state(body)] > 0} { - if {[catch { - foreach coding [ContentEncoding $token] { - set state(body) [zlib $coding $state(body)] - } - } err]} { - Log "error doing decompression: $err" - return [Finish $token $err] - } - - if {!$state(binary)} { - # If we are getting text, set the incoming channel's encoding - # correctly. iso8859-1 is the RFC default, but this could be any IANA - # charset. However, we only know how to convert what we have - # encodings for. - - set enc [CharsetToEncoding $state(charset)] - if {$enc ne "binary"} { - set state(body) [encoding convertfrom $enc $state(body)] - } - - # Translate text line endings. - set state(body) [string map {\r\n \n \r \n} $state(body)] - } - } - Finish $token -} - -# http::wait -- -# -# See documentation for details. -# -# Arguments: -# token Connection token. -# -# Results: -# The status after the wait. - -proc http::wait {token} { - variable $token - upvar 0 $token state - - if {![info exists state(status)] || $state(status) eq ""} { - # We must wait on the original variable name, not the upvar alias - vwait ${token}(status) - } - - return [status $token] -} - -# http::formatQuery -- -# -# See documentation for details. Call http::formatQuery with an even -# number of arguments, where the first is a name, the second is a value, -# the third is another name, and so on. -# -# Arguments: -# args A list of name-value pairs. -# -# Results: -# TODO - -proc http::formatQuery {args} { - set result "" - set sep "" - foreach i $args { - append result $sep [mapReply $i] - if {$sep eq "="} { - set sep & - } else { - set sep = - } - } - return $result -} - -# http::mapReply -- -# -# Do x-www-urlencoded character mapping -# -# Arguments: -# string The string the needs to be encoded -# -# Results: -# The encoded string - -proc http::mapReply {string} { - variable http - variable formMap - - # The spec says: "non-alphanumeric characters are replaced by '%HH'". Use - # a pre-computed map and [string map] to do the conversion (much faster - # than [regsub]/[subst]). [Bug 1020491] - - if {$http(-urlencoding) ne ""} { - set string [encoding convertto $http(-urlencoding) $string] - return [string map $formMap $string] - } - set converted [string map $formMap $string] - if {[string match "*\[\u0100-\uffff\]*" $converted]} { - regexp "\[\u0100-\uffff\]" $converted badChar - # Return this error message for maximum compatibility... :^/ - return -code error \ - "can't read \"formMap($badChar)\": no such element in array" - } - return $converted -} - -# http::ProxyRequired -- -# Default proxy filter. -# -# Arguments: -# host The destination host -# -# Results: -# The current proxy settings - -proc http::ProxyRequired {host} { - variable http - if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} { - if { - ![info exists http(-proxyport)] || - ![string length $http(-proxyport)] - } { - set http(-proxyport) 8080 - } - return [list $http(-proxyhost) $http(-proxyport)] - } -} - -# http::CharsetToEncoding -- -# -# Tries to map a given IANA charset to a tcl encoding. If no encoding -# can be found, returns binary. -# - -proc http::CharsetToEncoding {charset} { - variable encodings - - set charset [string tolower $charset] - if {[regexp {iso-?8859-([0-9]+)} $charset -> num]} { - set encoding "iso8859-$num" - } elseif {[regexp {iso-?2022-(jp|kr)} $charset -> ext]} { - set encoding "iso2022-$ext" - } elseif {[regexp {shift[-_]?js} $charset]} { - set encoding "shiftjis" - } elseif {[regexp {(?:windows|cp)-?([0-9]+)} $charset -> num]} { - set encoding "cp$num" - } elseif {$charset eq "us-ascii"} { - set encoding "ascii" - } elseif {[regexp {(?:iso-?)?lat(?:in)?-?([0-9]+)} $charset -> num]} { - switch -- $num { - 5 {set encoding "iso8859-9"} - 1 - 2 - 3 { - set encoding "iso8859-$num" - } - } - } else { - # other charset, like euc-xx, utf-8,... may directly map to encoding - set encoding $charset - } - set idx [lsearch -exact $encodings $encoding] - if {$idx >= 0} { - return $encoding - } else { - return "binary" - } -} - -# Return the list of content-encoding transformations we need to do in order. -proc http::ContentEncoding {token} { - upvar 0 $token state - set r {} - if {[info exists state(coding)]} { - foreach coding [split $state(coding) ,] { - switch -exact -- $coding { - deflate { lappend r inflate } - gzip - x-gzip { lappend r gunzip } - compress - x-compress { lappend r decompress } - identity {} - default { - return -code error "unsupported content-encoding \"$coding\"" - } - } - } - } - return $r -} - -proc http::make-transformation-chunked {chan command} { - set lambda {{chan command} { - set data "" - set size -1 - yield - while {1} { - chan configure $chan -translation {crlf binary} - while {[gets $chan line] < 1} { yield } - chan configure $chan -translation {binary binary} - if {[scan $line %x size] != 1} { return -code error "invalid size: \"$line\"" } - set chunk "" - while {$size && ![chan eof $chan]} { - set part [chan read $chan $size] - incr size -[string length $part] - append chunk $part - } - if {[catch { - uplevel #0 [linsert $command end $chunk] - }]} { - http::Log "Error in callback: $::errorInfo" - } - if {[string length $chunk] == 0} { - # channel might have been closed in the callback - catch {chan event $chan readable {}} - return - } - } - }} - coroutine dechunk$chan ::apply $lambda $chan $command - chan event $chan readable [namespace origin dechunk$chan] - return -} - -# Local variables: -# indent-tabs-mode: t -# End: diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8/8.6/tdbc/sqlite3-1.0.6.tm b/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8/8.6/tdbc/sqlite3-1.0.6.tm @@ -1,715 +0,0 @@ -# tdbcsqlite3.tcl -- -# -# SQLite3 database driver for TDBC -# -# Copyright (c) 2008 by Kevin B. Kenny. -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: tdbcodbc.tcl,v 1.47 2008/02/27 02:08:27 kennykb Exp $ -# -#------------------------------------------------------------------------------ - -package require tdbc -package require sqlite3 - -package provide tdbc::sqlite3 1.0.6 - -namespace eval tdbc::sqlite3 { - namespace export connection -} - -#------------------------------------------------------------------------------ -# -# tdbc::sqlite3::connection -- -# -# Class representing a SQLite3 database connection -# -#------------------------------------------------------------------------------ - -::oo::class create ::tdbc::sqlite3::connection { - - superclass ::tdbc::connection - - variable timeout - - # The constructor accepts a database name and opens the database. - - constructor {databaseName args} { - set timeout 0 - if {[llength $args] % 2 != 0} { - set cmd [lrange [info level 0] 0 end-[llength $args]] - return -code error \ - -errorcode {TDBC GENERAL_ERROR HY000 SQLITE3 WRONGNUMARGS} \ - "wrong # args, should be \"$cmd ?-option value?...\"" - } - next - sqlite3 [namespace current]::db $databaseName - if {[llength $args] > 0} { - my configure {*}$args - } - db nullvalue \ufffd - } - - # The 'statementCreate' method forwards to the constructor of the - # statement class - - forward statementCreate ::tdbc::sqlite3::statement create - - # The 'configure' method queries and sets options to the database - - method configure args { - if {[llength $args] == 0} { - - # Query all configuration options - - set result {-encoding utf-8} - lappend result -isolation - if {[db onecolumn {PRAGMA read_uncommitted}]} { - lappend result readuncommitted - } else { - lappend result serializable - } - lappend result -readonly 0 - lappend result -timeout $timeout - return $result - - } elseif {[llength $args] == 1} { - - # Query a single option - - set option [lindex $args 0] - switch -exact -- $option { - -e - -en - -enc - -enco - -encod - -encodi - -encodin - - -encoding { - return utf-8 - } - -i - -is - -iso - -isol - -isola - -isolat - -isolati - - -isolatio - -isolation { - if {[db onecolumn {PRAGMA read_uncommitted}]} { - return readuncommitted - } else { - return serializable - } - } - -r - -re - -rea - -read - -reado - -readon - -readonl - - -readonly { - return 0 - } - -t - -ti - -tim - -time - -timeo - -timeou - -timeout { - return $timeout - } - default { - return -code error \ - -errorcode [list TDBC GENERAL_ERROR HY000 SQLITE3 \ - BADOPTION $option] \ - "bad option \"$option\": must be\ - -encoding, -isolation, -readonly or -timeout" - - } - } - - } elseif {[llength $args] % 2 != 0} { - - # Syntax error - - set cmd [lrange [info level 0] 0 end-[llength $args]] - return -code error \ - -errorcode [list TDBC GENERAL_ERROR HY000 \ - SQLITE3 WRONGNUMARGS] \ - "wrong # args, should be \" $cmd ?-option value?...\"" - } - - # Set one or more options - - foreach {option value} $args { - switch -exact -- $option { - -e - -en - -enc - -enco - -encod - -encodi - -encodin - - -encoding { - if {$value ne {utf-8}} { - return -code error \ - -errorcode [list TDBC FEATURE_NOT_SUPPORTED 0A000 \ - SQLITE3 ENCODING] \ - "-encoding not supported. SQLite3 is always \ - Unicode." - } - } - -i - -is - -iso - -isol - -isola - -isolat - -isolati - - -isolatio - -isolation { - switch -exact -- $value { - readu - readun - readunc - readunco - readuncom - - readuncomm - readuncommi - readuncommit - - readuncommitt - readuncommitte - readuncommitted { - db eval {PRAGMA read_uncommitted = 1} - } - readc - readco - readcom - readcomm - readcommi - - readcommit - readcommitt - readcommitte - - readcommitted - - rep - repe - repea - repeat - repeata - repeatab - - repeatabl - repeatable - repeatabler - repeatablere - - repeatablerea - repeatablread - - s - se - ser - seri - seria - serial - seriali - - serializ - serializa - serializab - serializabl - - serializable - - reado - readon - readonl - readonly { - db eval {PRAGMA read_uncommitted = 0} - } - default { - return -code error \ - -errorcode [list TDBC GENERAL_ERROR HY000 \ - SQLITE3 BADISOLATION $value] \ - "bad isolation level \"$value\":\ - should be readuncommitted, readcommitted,\ - repeatableread, serializable, or readonly" - } - } - } - -r - -re - -rea - -read - -reado - -readon - -readonl - - -readonly { - if {$value} { - return -code error \ - -errorcode [list TDBC FEATURE_NOT_SUPPORTED 0A000 \ - SQLITE3 READONLY] \ - "SQLite3's Tcl API does not support read-only\ - access" - } - } - -t - -ti - -tim - -time - -timeo - -timeou - -timeout { - if {![string is integer $value]} { - return -code error \ - -errorcode [list TDBC DATA_EXCEPTION 22018 \ - SQLITE3 $value] \ - "expected integer but got \"$value\"" - } - db timeout $value - set timeout $value - } - default { - return -code error \ - -errorcode [list TDBC GENERAL_ERROR HY000 \ - SQLITE3 BADOPTION $value] \ - "bad option \"$option\": must be\ - -encoding, -isolation, -readonly or -timeout" - - } - } - } - return - } - - # The 'tables' method introspects on the tables in the database. - - method tables {{pattern %}} { - set retval {} - my foreach row { - SELECT * from sqlite_master - WHERE type IN ('table', 'view') - AND name LIKE :pattern - } { - dict set row name [string tolower [dict get $row name]] - dict set retval [dict get $row name] $row - } - return $retval - } - - # The 'columns' method introspects on columns of a table. - - method columns {table {pattern %}} { - regsub -all ' $table '' table - set retval {} - set pattern [string map [list \ - * {[*]} \ - ? {[?]} \ - \[ \\\[ \ - \] \\\[ \ - _ ? \ - % *] [string tolower $pattern]] - my foreach origrow "PRAGMA table_info('$table')" { - set row {} - dict for {key value} $origrow { - dict set row [string tolower $key] $value - } - dict set row name [string tolower [dict get $row name]] - if {![string match $pattern [dict get $row name]]} { - continue - } - switch -regexp -matchvar info [dict get $row type] { - {^(.+)\(\s*([[:digit:]]+)\s*,\s*([[:digit:]]+)\s*\)\s*$} { - dict set row type [string tolower [lindex $info 1]] - dict set row precision [lindex $info 2] - dict set row scale [lindex $info 3] - } - {^(.+)\(\s*([[:digit:]]+)\s*\)\s*$} { - dict set row type [string tolower [lindex $info 1]] - dict set row precision [lindex $info 2] - dict set row scale 0 - } - default { - dict set row type [string tolower [dict get $row type]] - dict set row precision 0 - dict set row scale 0 - } - } - dict set row nullable [expr {![dict get $row notnull]}] - dict set retval [dict get $row name] $row - } - return $retval - } - - # The 'primarykeys' method enumerates the primary keys on a table. - - method primarykeys {table} { - set result {} - my foreach row "PRAGMA table_info($table)" { - if {[dict get $row pk]} { - lappend result [dict create ordinalPosition \ - [expr {[dict get $row cid]+1}] \ - columnName \ - [dict get $row name]] - } - } - return $result - } - - # The 'foreignkeys' method enumerates the foreign keys that are - # declared in a table or that refer to a given table. - - method foreignkeys {args} { - - variable ::tdbc::generalError - - # Check arguments - - set argdict {} - if {[llength $args] % 2 != 0} { - set errorcode $generalError - lappend errorcode wrongNumArgs - return -code error -errorcode $errorcode \ - "wrong # args: should be [lrange [info level 0] 0 1]\ - ?-option value?..." - } - foreach {key value} $args { - if {$key ni {-primary -foreign}} { - set errorcode $generalError - lappend errorcode badOption - return -code error -errorcode $errorcode \ - "bad option \"$key\", must be -primary or -foreign" - } - set key [string range $key 1 end] - if {[dict exists $argdict $key]} { - set errorcode $generalError - lappend errorcode dupOption - return -code error -errorcode $errorcode \ - "duplicate option \"$key\" supplied" - } - dict set argdict $key $value - } - - # If we know the table with the foreign key, search just its - # foreign keys. Otherwise, iterate over all the tables in the - # database. - - if {[dict exists $argdict foreign]} { - return [my ForeignKeysForTable [dict get $argdict foreign] \ - $argdict] - } else { - set result {} - foreach foreignTable [dict keys [my tables]] { - lappend result {*}[my ForeignKeysForTable \ - $foreignTable $argdict] - } - return $result - } - - } - - # The private ForeignKeysForTable method enumerates the foreign keys - # in a specific table. - # - # Parameters: - # - # foreignTable - Name of the table containing foreign keys. - # argdict - Dictionary that may or may not contain a key, - # 'primary', whose value is the name of a table that - # must hold the primary key corresponding to the foreign - # key. If the 'primary' key is absent, all tables are - # candidates. - # Results: - # - # Returns the list of foreign keys that meed the specified - # conditions, as a list of dictionaries, each containing the - # keys, foreignConstraintName, foreignTable, foreignColumn, - # primaryTable, primaryColumn, and ordinalPosition. Note that the - # foreign constraint name is constructed arbitrarily, since SQLite3 - # does not report this information. - - method ForeignKeysForTable {foreignTable argdict} { - - set result {} - set n 0 - - # Go through the foreign keys in the given table, looking for - # ones that refer to the primary table (if one is given), or - # for any primary keys if none is given. - my foreach row "PRAGMA foreign_key_list($foreignTable)" { - if {(![dict exists $argdict primary]) - || ([string tolower [dict get $row table]] - eq [dict get $argdict primary])} { - - # Construct a dictionary for each key, translating - # SQLite names to TDBC ones and converting sequence - # numbers to 1-based indexing. - - set rrow [dict create foreignTable $foreignTable \ - foreignConstraintName \ - ?$foreignTable?[dict get $row id]] - if {[dict exists $row seq]} { - dict set rrow ordinalPosition \ - [expr {1 + [dict get $row seq]}] - } - foreach {to from} { - foreignColumn from - primaryTable table - primaryColumn to - deleteAction on_delete - updateAction on_update - } { - if {[dict exists $row $from]} { - dict set rrow $to [dict get $row $from] - } - } - - # Add the newly-constucted dictionary to the result list - - lappend result $rrow - } - } - - return $result - } - - # The 'preparecall' method prepares a call to a stored procedure. - # SQLite3 does not have stored procedures, since it's an in-process - # server. - - method preparecall {call} { - return -code error \ - -errorcode [list TDBC FEATURE_NOT_SUPPORTED 0A000 \ - SQLITE3 PREPARECALL] \ - {SQLite3 does not support stored procedures} - } - - # The 'begintransaction' method launches a database transaction - - method begintransaction {} { - db eval {BEGIN TRANSACTION} - } - - # The 'commit' method commits a database transaction - - method commit {} { - db eval {COMMIT} - } - - # The 'rollback' method abandons a database transaction - - method rollback {} { - db eval {ROLLBACK} - } - - # The 'transaction' method executes a script as a single transaction. - # We override the 'transaction' method of the base class, since SQLite3 - # has a faster implementation of the same thing. (The base class's generic - # method should also work.) - # (Don't overload the base class method, because 'break', 'continue' - # and 'return' in the transaction body don't work!) - - #method transaction {script} { - # uplevel 1 [list {*}[namespace code db] transaction $script] - #} - - method prepare {sqlCode} { - set result [next $sqlCode] - return $result - } - - method getDBhandle {} { - return [namespace which db] - } -} - -#------------------------------------------------------------------------------ -# -# tdbc::sqlite3::statement -- -# -# Class representing a statement to execute against a SQLite3 database -# -#------------------------------------------------------------------------------ - -::oo::class create ::tdbc::sqlite3::statement { - - superclass ::tdbc::statement - - variable Params db sql - - # The constructor accepts the handle to the connection and the SQL - # code for the statement to prepare. All that it does is to parse the - # statement and store it. The parse is used to support the - # 'params' and 'paramtype' methods. - - constructor {connection sqlcode} { - next - set Params {} - set db [$connection getDBhandle] - set sql $sqlcode - foreach token [::tdbc::tokenize $sqlcode] { - if {[string index $token 0] in {$ : @}} { - dict set Params [string range $token 1 end] \ - {type Tcl_Obj precision 0 scale 0 nullable 1 direction in} - } - } - } - - # The 'resultSetCreate' method relays to the result set constructor - - forward resultSetCreate ::tdbc::sqlite3::resultset create - - # The 'params' method returns descriptions of the parameters accepted - # by the statement - - method params {} { - return $Params - } - - # The 'paramtype' method need do nothing; Sqlite3 uses manifest typing. - - method paramtype args {;} - - method getDBhandle {} { - return $db - } - - method getSql {} { - return $sql - } - -} - -#------------------------------------------------------------------------------- -# -# tdbc::sqlite3::resultset -- -# -# Class that represents a SQLlite result set in Tcl -# -#------------------------------------------------------------------------------- - -::oo::class create ::tdbc::sqlite3::resultset { - - superclass ::tdbc::resultset - - # The variables of this class all have peculiar names. The reason is - # that the RunQuery method needs to execute with an activation record - # that has no local variables whose names could conflict with names - # in the SQL query. We start the variable names with hyphens because - # they can't be bind variables. - - variable -set {*}{ - -columns -db -needcolumns -resultArray - -results -sql -Cursor -RowCount -END - } - - constructor {statement args} { - next - set -db [$statement getDBhandle] - set -sql [$statement getSql] - set -columns {} - set -results {} - ${-db} trace [namespace code {my RecordStatement}] - if {[llength $args] == 0} { - - # Variable substitutions are evaluated in caller's context - - uplevel 1 [list ${-db} eval ${-sql} \ - [namespace which -variable -resultArray] \ - [namespace code {my RecordResult}]] - - } elseif {[llength $args] == 1} { - - # Variable substitutions are in the dictionary at [lindex $args 0]. - - set -paramDict [lindex $args 0] - - # At this point, the activation record must contain no variables - # that might be bound within the query. All variables at this point - # begin with hyphens so that they are syntactically incorrect - # as bound variables in SQL. - - unset args - unset statement - - dict with -paramDict { - ${-db} eval ${-sql} -resultArray { - my RecordResult - } - } - - } else { - - ${-db} trace {} - - # Too many args - - return -code error \ - -errorcode [list TDBC GENERAL_ERROR HY000 \ - SQLITE3 WRONGNUMARGS] \ - "wrong # args: should be\ - [lrange [info level 0] 0 1] statement ?dictionary?" - - } - ${-db} trace {} - set -Cursor 0 - if {${-Cursor} < [llength ${-results}] - && [lindex ${-results} ${-Cursor}] eq {statement}} { - incr -Cursor 2 - } - if {${-Cursor} < [llength ${-results}] - && [lindex ${-results} ${-Cursor}] eq {columns}} { - incr -Cursor - set -columns [lindex ${-results} ${-Cursor}] - incr -Cursor - } - set -RowCount [${-db} changes] - } - - # Record the start of a SQL statement - - method RecordStatement {stmt} { - set -needcolumns 1 - lappend -results statement {} - } - - # Record one row of results from a query by appending it as a dictionary - # to the 'results' list. As a side effect, set 'columns' to a list - # comprising the names of the columns of the result. - - method RecordResult {} { - set columns ${-resultArray(*)} - if {[info exists -needcolumns]} { - lappend -results columns $columns - unset -needcolumns - } - set dict {} - foreach key $columns { - if {[set -resultArray($key)] ne "\ufffd"} { - dict set dict $key [set -resultArray($key)] - } - } - lappend -results row $dict - } - - # Advance to the next result set - - method nextresults {} { - set have 0 - while {${-Cursor} < [llength ${-results}]} { - if {[lindex ${-results} ${-Cursor}] eq {statement}} { - set have 1 - incr -Cursor 2 - break - } - incr -Cursor 2 - } - if {!$have} { - set -END {} - } - if {${-Cursor} >= [llength ${-results}]} { - set -columns {} - } elseif {[lindex ${-results} ${-Cursor}] eq {columns}} { - incr -Cursor - set -columns [lindex ${-results} ${-Cursor}] - incr -Cursor - } else { - set -columns {} - } - return $have - } - - method getDBhandle {} { - return ${-db} - } - - # Return a list of the columns - - method columns {} { - if {[info exists -END]} { - return -code error \ - -errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \ - "Function sequence error: result set is exhausted." - } - return ${-columns} - } - - # Return the next row of the result set as a list - - method nextlist var { - - upvar 1 $var row - - if {[info exists -END]} { - return -code error \ - -errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \ - "Function sequence error: result set is exhausted." - } - if {${-Cursor} >= [llength ${-results}] - || [lindex ${-results} ${-Cursor}] ne {row}} { - return 0 - } else { - set row {} - incr -Cursor - set d [lindex ${-results} ${-Cursor}] - incr -Cursor - foreach key ${-columns} { - if {[dict exists $d $key]} { - lappend row [dict get $d $key] - } else { - lappend row {} - } - } - } - return 1 - } - - # Return the next row of the result set as a dict - - method nextdict var { - - upvar 1 $var row - - if {[info exists -END]} { - return -code error \ - -errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \ - "Function sequence error: result set is exhausted." - } - if {${-Cursor} >= [llength ${-results}] - || [lindex ${-results} ${-Cursor}] ne {row}} { - return 0 - } else { - incr -Cursor - set row [lindex ${-results} ${-Cursor}] - incr -Cursor - } - return 1 - } - - # Return the number of rows affected by a statement - - method rowcount {} { - if {[info exists -END]} { - return -code error \ - -errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \ - "Function sequence error: result set is exhausted." - } - return ${-RowCount} - } - -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tclConfig.sh b/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tclConfig.sh @@ -1,169 +0,0 @@ -# tclConfig.sh -- -# -# This shell script (for sh) is generated automatically by Tcl's -# configure script. It will create shell variables for most of -# the configuration options discovered by the configure script. -# This script is intended to be included by the configure scripts -# for Tcl extensions so that they don't have to figure this all -# out for themselves. -# -# The information in this file is specific to a single platform. - -# Tcl's version number. -TCL_VERSION='8.6' -TCL_MAJOR_VERSION='8' -TCL_MINOR_VERSION='6' -TCL_PATCH_LEVEL='.8' - -# C compiler to use for compilation. -TCL_CC='gcc' - -# -D flags for use with the C compiler. -TCL_DEFS='-DPACKAGE_NAME=\"tcl\" -DPACKAGE_TARNAME=\"tcl\" -DPACKAGE_VERSION=\"8.6\" -DPACKAGE_STRING=\"tcl\ 8.6\" -DPACKAGE_BUGREPORT=\"\" -DSTDC_HEADERS=1 -DHAVE_SYS_TYPES_H=1 -DHAVE_SYS_STAT_H=1 -DHAVE_STDLIB_H=1 -DHAVE_STRING_H=1 -DHAVE_MEMORY_H=1 -DHAVE_STRINGS_H=1 -DHAVE_INTTYPES_H=1 -DHAVE_STDINT_H=1 -DHAVE_UNISTD_H=1 -DNO_VALUES_H=1 -DHAVE_SYS_PARAM_H=1 -DUSE_THREAD_ALLOC=1 -D_REENTRANT=1 -D_THREAD_SAFE=1 -DHAVE_PTHREAD_ATTR_SETSTACKSIZE=1 -DHAVE_PTHREAD_ATFORK=1 -DTCL_THREADS=1 -DTCL_CFGVAL_ENCODING=\"iso8859-1\" -DHAVE_ZLIB=1 -DMODULE_SCOPE=extern\ __attribute__\(\(__visibility__\(\"hidden\"\)\)\) -DHAVE_HIDDEN=1 -DMAC_OSX_TCL=1 -DHAVE_COREFOUNDATION=1 -DHAVE_CAST_TO_UNION=1 -DTCL_SHLIB_EXT=\".dylib\" -DNDEBUG=1 -DTCL_CFG_OPTIMIZED=1 -DTCL_TOMMATH=1 -DMP_PREC=4 -DTCL_WIDE_INT_IS_LONG=1 -DHAVE_GETCWD=1 -DHAVE_MKSTEMP=1 -DHAVE_OPENDIR=1 -DHAVE_STRTOL=1 -DHAVE_WAITPID=1 -DHAVE_GETNAMEINFO=1 -DHAVE_GETADDRINFO=1 -DHAVE_FREEADDRINFO=1 -DHAVE_GAI_STRERROR=1 -DHAVE_STRUCT_ADDRINFO=1 -DHAVE_STRUCT_IN6_ADDR=1 -DHAVE_STRUCT_SOCKADDR_IN6=1 -DHAVE_STRUCT_SOCKADDR_STORAGE=1 -DHAVE_GETPWUID_R_5=1 -DHAVE_GETPWUID_R=1 -DHAVE_GETPWNAM_R_5=1 -DHAVE_GETPWNAM_R=1 -DHAVE_GETGRGID_R_5=1 -DHAVE_GETGRGID_R=1 -DHAVE_GETGRNAM_R_5=1 -DHAVE_GETGRNAM_R=1 -DHAVE_MTSAFE_GETHOSTBYNAME=1 -DHAVE_MTSAFE_GETHOSTBYADDR=1 -DHAVE_TERMIOS_H=1 -DHAVE_SYS_IOCTL_H=1 -DHAVE_SYS_TIME_H=1 -DTIME_WITH_SYS_TIME=1 -DHAVE_GMTIME_R=1 -DHAVE_LOCALTIME_R=1 -DHAVE_MKTIME=1 -DHAVE_TM_GMTOFF=1 -DHAVE_TIMEZONE_VAR=1 -DHAVE_STRUCT_STAT_ST_BLOCKS=1 -DHAVE_STRUCT_STAT_ST_BLKSIZE=1 -DHAVE_BLKCNT_T=1 -DHAVE_INTPTR_T=1 -DHAVE_UINTPTR_T=1 -DHAVE_SIGNED_CHAR=1 -DHAVE_LANGINFO=1 -DHAVE_CHFLAGS=1 -DHAVE_MKSTEMPS=1 -DHAVE_GETATTRLIST=1 -DHAVE_COPYFILE_H=1 -DHAVE_COPYFILE=1 -DHAVE_LIBKERN_OSATOMIC_H=1 -DHAVE_OSSPINLOCKLOCK=1 -DUSE_VFORK=1 -DTCL_DEFAULT_ENCODING=\"utf-8\" -DTCL_LOAD_FROM_MEMORY=1 -DTCL_WIDE_CLICKS=1 -DHAVE_AVAILABILITYMACROS_H=1 -DHAVE_WEAK_IMPORT=1 -D_DARWIN_C_SOURCE=1 -DHAVE_FTS=1 -DHAVE_SYS_IOCTL_H=1 -DHAVE_SYS_FILIO_H=1 -DTCL_UNLOAD_DLLS=1 -DHAVE_CPUID=1 ' - -# TCL_DBGX used to be used to distinguish debug vs. non-debug builds. -# This was a righteous pain so the core doesn't do that any more. -TCL_DBGX= - -# Default flags used in an optimized and debuggable build, respectively. -TCL_CFLAGS_DEBUG='-g' -TCL_CFLAGS_OPTIMIZE='-Os' - -# Default linker flags used in an optimized and debuggable build, respectively. -TCL_LDFLAGS_DEBUG='' -TCL_LDFLAGS_OPTIMIZE='' - -# Flag, 1: we built a shared lib, 0 we didn't -TCL_SHARED_BUILD=1 - -# The name of the Tcl library (may be either a .a file or a shared library): -TCL_LIB_FILE='libtcl8.6.dylib' - -# Additional libraries to use when linking Tcl. -TCL_LIBS=' -lz -lpthread -framework CoreFoundation ' - -# Top-level directory in which Tcl's platform-independent files are -# installed. -TCL_PREFIX='/usr/local' - -# Top-level directory in which Tcl's platform-specific files (e.g. -# executables) are installed. -TCL_EXEC_PREFIX='/usr/local' - -# Flags to pass to cc when compiling the components of a shared library: -TCL_SHLIB_CFLAGS='-fno-common' - -# Flags to pass to cc to get warning messages -TCL_CFLAGS_WARNING='-Wall' - -# Extra flags to pass to cc: -TCL_EXTRA_CFLAGS='-arch x86_64 -I/tmp/_py/libraries/usr/local/include -pipe -mmacosx-version-min=10.9 ' - -# Base command to use for combining object files into a shared library: -TCL_SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS} -Wl,-single_module' - -# Base command to use for combining object files into a static library: -TCL_STLIB_LD='${AR} cr' - -# Either '$LIBS' (if dependent libraries should be included when linking -# shared libraries) or an empty string. See Tcl's configure.in for more -# explanation. -TCL_SHLIB_LD_LIBS='${LIBS}' - -# Suffix to use for the name of a shared library. -TCL_SHLIB_SUFFIX='.dylib' - -# Library file(s) to include in tclsh and other base applications -# in order to provide facilities needed by DLOBJ above. -TCL_DL_LIBS='' - -# Flags to pass to the compiler when linking object files into -# an executable tclsh or tcltest binary. -TCL_LD_FLAGS=' -headerpad_max_install_names -Wl,-search_paths_first ' - -# Flags to pass to cc/ld, such as "-R /usr/local/tcl/lib", that tell the -# run-time dynamic linker where to look for shared libraries such as -# libtcl.so. Used when linking applications. Only works if there -# is a variable "LIB_RUNTIME_DIR" defined in the Makefile. -TCL_CC_SEARCH_FLAGS='' -TCL_LD_SEARCH_FLAGS='' - -# Additional object files linked with Tcl to provide compatibility -# with standard facilities from ANSI C or POSIX. -TCL_COMPAT_OBJS='' - -# Name of the ranlib program to use. -TCL_RANLIB='ranlib' - -# -l flag to pass to the linker to pick up the Tcl library -TCL_LIB_FLAG='-ltcl8.6' - -# String to pass to linker to pick up the Tcl library from its -# build directory. -TCL_BUILD_LIB_SPEC='-L/private/tmp/_py/_bld/tcl8.6.8/unix -ltcl8.6' - -# String to pass to linker to pick up the Tcl library from its -# installed directory. -TCL_LIB_SPEC='-L/Library/Frameworks/Python.framework/Versions/3.7/lib -ltcl8.6' - -# String to pass to the compiler so that an extension can -# find installed Tcl headers. -TCL_INCLUDE_SPEC='-I/usr/local/include' - -# Indicates whether a version numbers should be used in -l switches -# ("ok" means it's safe to use switches like -ltcl7.5; "nodots" means -# use switches like -ltcl75). SunOS and FreeBSD require "nodots", for -# example. -TCL_LIB_VERSIONS_OK='ok' - -# String that can be evaluated to generate the part of a shared library -# name that comes after the "libxxx" (includes version number, if any, -# extension, and anything else needed). May depend on the variables -# VERSION and SHLIB_SUFFIX. On most UNIX systems this is -# ${VERSION}${SHLIB_SUFFIX}. -TCL_SHARED_LIB_SUFFIX='${VERSION}.dylib' - -# String that can be evaluated to generate the part of an unshared library -# name that comes after the "libxxx" (includes version number, if any, -# extension, and anything else needed). May depend on the variable -# VERSION. On most UNIX systems this is ${VERSION}.a. -TCL_UNSHARED_LIB_SUFFIX='${VERSION}.a' - -# Location of the top-level source directory from which Tcl was built. -# This is the directory that contains a README file as well as -# subdirectories such as generic, unix, etc. If Tcl was compiled in a -# different place than the directory containing the source files, this -# points to the location of the sources, not the location where Tcl was -# compiled. -TCL_SRC_DIR='/private/tmp/_py/_bld/tcl8.6.8' - -# List of standard directories in which to look for packages during -# "package require" commands. Contains the "prefix" directory plus also -# the "exec_prefix" directory, if it is different. -TCL_PACKAGE_PATH='/Library/Frameworks/Python.framework/Versions/3.7/lib /usr/local/lib ' - -# Tcl supports stub. -TCL_SUPPORTS_STUBS=1 - -# The name of the Tcl stub library (.a): -TCL_STUB_LIB_FILE='libtclstub8.6.a' - -# -l flag to pass to the linker to pick up the Tcl stub library -TCL_STUB_LIB_FLAG='-ltclstub8.6' - -# String to pass to linker to pick up the Tcl stub library from its -# build directory. -TCL_BUILD_STUB_LIB_SPEC='-L/private/tmp/_py/_bld/tcl8.6.8/unix -ltclstub8.6' - -# String to pass to linker to pick up the Tcl stub library from its -# installed directory. -TCL_STUB_LIB_SPEC='-L/Library/Frameworks/Python.framework/Versions/3.7/lib -ltclstub8.6' - -# Path to the Tcl stub library in the build directory. -TCL_BUILD_STUB_LIB_PATH='/private/tmp/_py/_bld/tcl8.6.8/unix/libtclstub8.6.a' - -# Path to the Tcl stub library in the install directory. -TCL_STUB_LIB_PATH='/Library/Frameworks/Python.framework/Versions/3.7/lib/libtclstub8.6.a' - -# Flag, 1: we built Tcl with threads enabled, 0 we didn't -TCL_THREADS=1 diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tclooConfig.sh b/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tclooConfig.sh @@ -1,19 +0,0 @@ -# tclooConfig.sh -- -# -# This shell script (for sh) is generated automatically by TclOO's configure -# script, or would be except it has no values that we substitute. It will -# create shell variables for most of the configuration options discovered by -# the configure script. This script is intended to be included by TEA-based -# configure scripts for TclOO extensions so that they don't have to figure -# this all out for themselves. -# -# The information in this file is specific to a single platform. - -# These are mostly empty because no special steps are ever needed from Tcl 8.6 -# onwards; all libraries and include files are just part of Tcl. -TCLOO_LIB_SPEC="" -TCLOO_STUB_LIB_SPEC="" -TCLOO_INCLUDE_SPEC="" -TCLOO_PRIVATE_INCLUDE_SPEC="" -TCLOO_CFLAGS="" -TCLOO_VERSION=1.1.0 diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/Tk.icns b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/Tk.icns Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/Tk.tiff b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/Tk.tiff Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/README b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/README @@ -1,44 +0,0 @@ -This directory contains a collection of programs to demonstrate -the features of the Tk toolkit. The programs are all scripts for -"wish", a windowing shell. If wish has been installed on your path -then you can invoke any of the programs in this directory just -by typing its file name to your command shell under Unix. Otherwise -invoke wish with the file as its first argument, e.g., "wish hello". -The rest of this file contains a brief description of each program. -Files with names ending in ".tcl" are procedure packages used by one -or more of the demo programs; they can't be used as programs by -themselves so they aren't described below. - -hello - Creates a single button; if you click on it, a message - is typed and the application terminates. - -widget - Contains a collection of demonstrations of the widgets - currently available in the Tk library. Most of the .tcl - files are scripts for individual demos available through - the "widget" program. - -ixset - A simple Tk-based wrapper for the "xset" program, which - allows you to interactively query and set various X options - such as mouse acceleration and bell volume. Thanks to - Pierre David for contributing this example. - -rolodex - A mock-up of a simple rolodex application. It has much of - the user interface for such an application but no back-end - database. This program was written in response to Tom - LaStrange's toolkit benchmark challenge. - -tcolor - A color editor. Allows you to edit colors in several - different ways, and will also perform automatic updates - using "send". - -rmt - Allows you to "hook-up" remotely to any Tk application - on the display. Select an application with the menu, - then just type commands: they'll go to that application. - -timer - Displays a seconds timer with start and stop buttons. - Control-c and control-q cause it to exit. - -browse - A simple directory browser. Invoke it with and argument - giving the name of the directory you'd like to browse. - Double-click on files or subdirectories to browse them. - Control-c and control-q cause the program to exit. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/anilabel.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/anilabel.tcl @@ -1,160 +0,0 @@ -# anilabel.tcl -- -# -# This demonstration script creates a toplevel window containing -# several animated label widgets. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .anilabel -catch {destroy $w} -toplevel $w -wm title $w "Animated Label Demonstration" -wm iconname $w "anilabel" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "Four animated labels are displayed below; each of the labels on the left is animated by making the text message inside it appear to scroll, and the label on the right is animated by animating the image that it displays." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -# Ensure that this this is an array -array set animationCallbacks {} - -## This callback is the core of how to do animation in Tcl/Tk; all -## animations work in basically the same way, with a procedure that -## uses the [after] command to reschedule itself at some point in the -## future. Of course, the details of how to update the state will vary -## according to what is being animated. -proc RotateLabelText {w interval} { - global animationCallbacks - - # Schedule the calling of this procedure again in the future - set animationCallbacks($w) [after $interval RotateLabelText $w $interval] - - # We do marquee-like scrolling text by chopping characters off the - # front of the text and sticking them on the end. - set text [$w cget -text] - set newText [string range $text 1 end][string index $text 0] - $w configure -text $newText -} - -## A helper procedure to start the animation happening. -proc animateLabelText {w text interval} { - global animationCallbacks - - # Install the text into the widget - $w configure -text $text - - # Schedule the start of the animation loop - set animationCallbacks($w) [after $interval RotateLabelText $w $interval] - - # Make sure that the animation stops and is cleaned up after itself - # when the animated label is destroyed. Note that at this point we - # cannot manipulate the widget itself, as that has already died. - bind $w <Destroy> { - after cancel $animationCallbacks(%W) - unset animationCallbacks(%W) - } -} - -## Next, a similar pair of procedures to animate a GIF loaded into a -## photo image. -proc SelectNextImageFrame {w interval} { - global animationCallbacks - set animationCallbacks($w) \ - [after $interval SelectNextImageFrame $w $interval] - set image [$w cget -image] - - # The easy way to animate a GIF! - set idx -1 - scan [$image cget -format] "GIF -index %d" idx - if {[catch { - # Note that we get an error if the index is out of range - $image configure -format "GIF -index [incr idx]" - }]} then { - $image configure -format "GIF -index 0" - } -} -proc animateLabelImage {w imageData interval} { - global animationCallbacks - - # Create a multi-frame GIF from base-64-encoded data - set image [image create photo -format GIF -data $imageData] - - # Install the image into the widget - $w configure -image $image - - # Schedule the start of the animation loop - set animationCallbacks($w) \ - [after $interval SelectNextImageFrame $w $interval] - - # Make sure that the animation stops and is cleaned up after itself - # when the animated label is destroyed. Note that at this point we - # cannot manipulate the widget itself, as that has already died. - # Also note that this script is in double-quotes; this is always OK - # because image names are chosen automatically to be simple words. - bind $w <Destroy> " - after cancel \$animationCallbacks(%W) - unset animationCallbacks(%W) - rename $image {} - " -} - -# Make some widgets to contain the animations -labelframe $w.left -text "Scrolling Texts" -labelframe $w.right -text "GIF Image" -pack $w.left $w.right -side left -padx 10 -pady 10 -expand yes - -# This method of scrolling text looks far better with a fixed-width font -label $w.left.l1 -bd 4 -relief ridge -font fixedFont -label $w.left.l2 -bd 4 -relief groove -font fixedFont -label $w.left.l3 -bd 4 -relief flat -font fixedFont -width 18 -pack $w.left.l1 $w.left.l2 $w.left.l3 -side top -expand yes -padx 10 -pady 10 -anchor w -# Don't need to do very much with this label except turn off the border -label $w.right.l -bd 0 -pack $w.right.l -side top -expand yes -padx 10 -pady 10 - -# This is a base-64-encoded animated GIF file. -set tclPoweredData { - R0lGODlhKgBAAPQAAP//////zP//AP/MzP/Mmf/MAP+Zmf+ZZv+ZAMz//8zM - zMyZmcyZZsxmZsxmAMwzAJnMzJmZzJmZmZlmmZlmZplmM5kzM2aZzGZmzGZm - mWZmZmYzZmYzMzNmzDMzZgAzmSH+IE1hZGUgd2l0aCBHSU1QIGJ5IExARGVt - YWlsbHkuY29tACH5BAVkAAEALAAAAAAqAEAAAAX+YCCOZEkyTKM2jOm66yPP - dF03bx7YcuHIDkGBR7SZeIyhTID4FZ+4Es8nQyCe2EeUNJ0peY2s9mi7PhAM - ngEAMGRbUpvzSxskLh1J+Hkg134OdDIDEB+GHxtYMEQMTjMGEYeGFoomezaC - DZGSHFmLXTQKkh8eNQVpZ2afmDQGHaOYSoEyhhcklzVmMpuHnaZmDqiGJbg0 - qFqvh6UNAwB7VA+OwydEjgujkgrPNhbTI8dFvNgEYcHcHx0lB1kX2IYeA2G6 - NN0YfkXJ2BsAMuAzHB9cZMk3qoEbRzUACsRCUBK5JxsC3iMiKd8GN088SIyT - 0RAFSROyeEg38caDiB/+JEgqxsODrZJ1BkT0oHKSmI0ceQxo94HDpg0qsuDk - UmRAMgu8OgwQ+uIJgUMVeGXA+IQkzEeHGvD8cIGlDXsLiRjQ+EHroQhea7xY - 8IQBSgYYDi1IS+OFBCgaDMGVS3fGi5BPJpBaENdQ0EomKGD56IHwO39EXiSC - Ysgxor5+Xfgq0qByYUpiXmwuoredB2aYH4gWWda0B7SeNENpEJHC1ghi+pS4 - AJpIAwWvKPBi+8YEht5EriEqpFfMlhEdkBNpx0HUhwypx5T4IB1MBg/Ws2sn - wV3MSQOkzI8fUd48Aw3dOZto71x85hHtHijYv18Gf/3GqCdDCXHNoICBobSo - IqBqJLyCoH8JPrLgdh88CKCFD0CGmAiGYPgffwceZh6FC2ohIIklnkhehTNY - 4CIHHGzgwYw01ujBBhvAqKOLLq5AAk9kuSPkkKO40NB+h1gnypJIIvkBf09a - N5QIRz5p5ZJXJpmlIVhOGQA2TmIJZZhKKmmll2BqyWSXWUrZpQtpatlmk1c2 - KaWRHeTZEJF8SqLDn/hhsOeQgBbqAh6DGqronxeARUIIACH5BAUeAAAALAUA - LgAFAAUAAAUM4CeKz/OV5YmqaRkCACH5BAUeAAEALAUALgAKAAUAAAUUICCK - z/OdJVCaa7p+7aOWcDvTZwgAIfkEBR4AAQAsCwAuAAkABQAABRPgA4zP95zA - eZqoWqqpyqLkZ38hACH5BAUKAAEALAcALgANAA4AAAU7ICA+jwiUJEqeKau+ - r+vGaTmac63v/GP9HM7GQyx+jsgkkoRUHJ3Qx0cK/VQVTKtWwbVKn9suNunc - WkMAIfkEBQoAAAAsBwA3AAcABQAABRGgIHzk842j+Yjlt5KuO8JmCAAh+QQF - CgAAACwLADcABwAFAAAFEeAnfN9TjqP5oOWziq05lmUIACH5BAUKAAAALA8A - NwAHAAUAAAUPoPCJTymS3yiQj4qOcPmEACH5BAUKAAAALBMANwAHAAUAAAUR - oCB+z/MJX2o+I2miKimiawgAIfkEBQoAAAAsFwA3AAcABQAABRGgIHzfY47j - Q4qk+aHl+pZmCAAh+QQFCgAAACwbADcABwAFAAAFEaAgfs/zCV9qPiNJouo7 - ll8IACH5BAUKAAAALB8ANwADAAUAAAUIoCB8o0iWZggAOw== -} - -# Finally, set up the text scrolling animation -animateLabelText $w.left.l1 "* Slow Animation *" 300 -animateLabelText $w.left.l2 "* Fast Animation *" 80 -animateLabelText $w.left.l3 "This is a longer scrolling text in a widget that will not show the whole message at once. " 150 -animateLabelImage $w.right.l $tclPoweredData 100 diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/aniwave.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/aniwave.tcl @@ -1,104 +0,0 @@ -# aniwave.tcl -- -# -# This demonstration script illustrates how to adjust canvas item -# coordinates in a way that does something fairly similar to waveform -# display. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .aniwave -catch {destroy $w} -toplevel $w -wm title $w "Animated Wave Demonstration" -wm iconname $w "aniwave" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration contains a canvas widget with a line item inside it. The animation routines work by adjusting the coordinates list of the line; a trace on a variable is used so updates to the variable result in a change of position of the line." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -# Create a canvas large enough to hold the wave. In fact, the wave -# sticks off both sides of the canvas to prevent visual glitches. -pack [canvas $w.c -width 300 -height 200 -background black] -padx 10 -pady 10 -expand yes - -# Ensure that this this is an array -array set animationCallbacks {} - -# Creates a coordinates list of a wave. This code does a very sketchy -# job and relies on Tk's line smoothing to make things look better. -set waveCoords {} -for {set x -10} {$x<=300} {incr x 5} { - lappend waveCoords $x 100 -} -lappend waveCoords $x 0 [incr x 5] 200 - -# Create a smoothed line and arrange for its coordinates to be the -# contents of the variable waveCoords. -$w.c create line $waveCoords -tags wave -width 1 -fill green -smooth 1 -proc waveCoordsTracer {w args} { - global waveCoords - # Actual visual update will wait until we have finished - # processing; Tk does that for us automatically. - $w.c coords wave $waveCoords -} -trace add variable waveCoords write [list waveCoordsTracer $w] - -# Basic motion handler. Given what direction the wave is travelling -# in, it advances the y coordinates in the coordinate-list one step in -# that direction. -proc basicMotion {} { - global waveCoords direction - set oc $waveCoords - for {set i 1} {$i<[llength $oc]} {incr i 2} { - if {$direction eq "left"} { - lset waveCoords $i [lindex $oc \ - [expr {$i+2>[llength $oc] ? 1 : $i+2}]] - } else { - lset waveCoords $i \ - [lindex $oc [expr {$i-2<0 ? "end" : $i-2}]] - } - } -} - -# Oscillation handler. This detects whether to reverse the direction -# of the wave by checking to see if the peak of the wave has moved off -# the screen (whose size we know already.) -proc reverser {} { - global waveCoords direction - if {[lindex $waveCoords 1] < 10} { - set direction "right" - } elseif {[lindex $waveCoords end] < 10} { - set direction "left" - } -} - -# Main animation "loop". This calls the two procedures that handle the -# movement repeatedly by scheduling asynchronous calls back to itself -# using the [after] command. This procedure is the fundamental basis -# for all animated effect handling in Tk. -proc move {} { - basicMotion - reverser - - # Theoretically 100 frames-per-second (==10ms between frames) - global animationCallbacks - set animationCallbacks(simpleWave) [after 10 move] -} - -# Initialise our remaining animation variables -set direction "left" -set animateAfterCallback {} -# Arrange for the animation loop to stop when the canvas is deleted -bind $w.c <Destroy> { - after cancel $animationCallbacks(simpleWave) - unset animationCallbacks(simpleWave) -} -# Start the animation processing -move diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/arrow.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/arrow.tcl @@ -1,237 +0,0 @@ -# arrow.tcl -- -# -# This demonstration script creates a canvas widget that displays a -# large line with an arrowhead whose shape can be edited interactively. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -# arrowSetup -- -# This procedure regenerates all the text and graphics in the canvas -# window. It's called when the canvas is initially created, and also -# whenever any of the parameters of the arrow head are changed -# interactively. -# -# Arguments: -# c - Name of the canvas widget. - -proc arrowSetup c { - upvar #0 demo_arrowInfo v - - # Remember the current box, if there is one. - - set tags [$c gettags current] - if {$tags != ""} { - set cur [lindex $tags [lsearch -glob $tags box?]] - } else { - set cur "" - } - - # Create the arrow and outline. - - $c delete all - eval {$c create line $v(x1) $v(y) $v(x2) $v(y) -arrow last \ - -width [expr {10*$v(width)}] -arrowshape [list \ - [expr {10*$v(a)}] [expr {10*$v(b)}] [expr {10*$v(c)}]]} \ - $v(bigLineStyle) - set xtip [expr {$v(x2)-10*$v(b)}] - set deltaY [expr {10*$v(c)+5*$v(width)}] - $c create line $v(x2) $v(y) $xtip [expr {$v(y)+$deltaY}] \ - [expr {$v(x2)-10*$v(a)}] $v(y) $xtip [expr {$v(y)-$deltaY}] \ - $v(x2) $v(y) -width 2 -capstyle round -joinstyle round - - # Create the boxes for reshaping the line and arrowhead. - - eval {$c create rect [expr {$v(x2)-10*$v(a)-5}] [expr {$v(y)-5}] \ - [expr {$v(x2)-10*$v(a)+5}] [expr {$v(y)+5}] \ - -tags {box1 box}} $v(boxStyle) - eval {$c create rect [expr {$xtip-5}] [expr {$v(y)-$deltaY-5}] \ - [expr {$xtip+5}] [expr {$v(y)-$deltaY+5}] \ - -tags {box2 box}} $v(boxStyle) - eval {$c create rect [expr {$v(x1)-5}] [expr {$v(y)-5*$v(width)-5}] \ - [expr {$v(x1)+5}] [expr {$v(y)-5*$v(width)+5}] \ - -tags {box3 box}} $v(boxStyle) - if {$cur != ""} { - eval $c itemconfigure $cur $v(activeStyle) - } - - # Create three arrows in actual size with the same parameters - - $c create line [expr {$v(x2)+50}] 0 [expr {$v(x2)+50}] 1000 \ - -width 2 - set tmp [expr {$v(x2)+100}] - $c create line $tmp [expr {$v(y)-125}] $tmp [expr {$v(y)-75}] \ - -width $v(width) \ - -arrow both -arrowshape "$v(a) $v(b) $v(c)" - $c create line [expr {$tmp-25}] $v(y) [expr {$tmp+25}] $v(y) \ - -width $v(width) \ - -arrow both -arrowshape "$v(a) $v(b) $v(c)" - $c create line [expr {$tmp-25}] [expr {$v(y)+75}] [expr {$tmp+25}] \ - [expr {$v(y)+125}] -width $v(width) \ - -arrow both -arrowshape "$v(a) $v(b) $v(c)" - - # Create a bunch of other arrows and text items showing the - # current dimensions. - - set tmp [expr {$v(x2)+10}] - $c create line $tmp [expr {$v(y)-5*$v(width)}] \ - $tmp [expr {$v(y)-$deltaY}] \ - -arrow both -arrowshape $v(smallTips) - $c create text [expr {$v(x2)+15}] [expr {$v(y)-$deltaY+5*$v(c)}] \ - -text $v(c) -anchor w - set tmp [expr {$v(x1)-10}] - $c create line $tmp [expr {$v(y)-5*$v(width)}] \ - $tmp [expr {$v(y)+5*$v(width)}] \ - -arrow both -arrowshape $v(smallTips) - $c create text [expr {$v(x1)-15}] $v(y) -text $v(width) -anchor e - set tmp [expr {$v(y)+5*$v(width)+10*$v(c)+10}] - $c create line [expr {$v(x2)-10*$v(a)}] $tmp $v(x2) $tmp \ - -arrow both -arrowshape $v(smallTips) - $c create text [expr {$v(x2)-5*$v(a)}] [expr {$tmp+5}] \ - -text $v(a) -anchor n - set tmp [expr {$tmp+25}] - $c create line [expr {$v(x2)-10*$v(b)}] $tmp $v(x2) $tmp \ - -arrow both -arrowshape $v(smallTips) - $c create text [expr {$v(x2)-5*$v(b)}] [expr {$tmp+5}] \ - -text $v(b) -anchor n - - $c create text $v(x1) 310 -text "-width $v(width)" \ - -anchor w -font {Helvetica 18} - $c create text $v(x1) 330 -text "-arrowshape {$v(a) $v(b) $v(c)}" \ - -anchor w -font {Helvetica 18} - - incr v(count) -} - -set w .arrow -catch {destroy $w} -toplevel $w -wm title $w "Arrowhead Editor Demonstration" -wm iconname $w "arrow" -positionWindow $w -set c $w.c - -label $w.msg -font $font -wraplength 5i -justify left -text "This widget allows you to experiment with different widths and arrowhead shapes for lines in canvases. To change the line width or the shape of the arrowhead, drag any of the three boxes attached to the oversized arrow. The arrows on the right give examples at normal scale. The text at the bottom shows the configuration options as you'd enter them for a canvas line item." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -canvas $c -width 500 -height 350 -relief sunken -borderwidth 2 -pack $c -expand yes -fill both - -set demo_arrowInfo(a) 8 -set demo_arrowInfo(b) 10 -set demo_arrowInfo(c) 3 -set demo_arrowInfo(width) 2 -set demo_arrowInfo(motionProc) arrowMoveNull -set demo_arrowInfo(x1) 40 -set demo_arrowInfo(x2) 350 -set demo_arrowInfo(y) 150 -set demo_arrowInfo(smallTips) {5 5 2} -set demo_arrowInfo(count) 0 -if {[winfo depth $c] > 1} { - set demo_arrowInfo(bigLineStyle) "-fill SkyBlue1" - set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 1" - set demo_arrowInfo(activeStyle) "-fill red -outline black -width 1" -} else { - # Main widget program sets variable tk_demoDirectory - set demo_arrowInfo(bigLineStyle) "-fill black \ - -stipple @[file join $tk_demoDirectory images grey.25]" - set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 1" - set demo_arrowInfo(activeStyle) "-fill black -outline black -width 1" -} -arrowSetup $c -$c bind box <Enter> "$c itemconfigure current $demo_arrowInfo(activeStyle)" -$c bind box <Leave> "$c itemconfigure current $demo_arrowInfo(boxStyle)" -$c bind box <B1-Enter> " " -$c bind box <B1-Leave> " " -$c bind box1 <1> {set demo_arrowInfo(motionProc) arrowMove1} -$c bind box2 <1> {set demo_arrowInfo(motionProc) arrowMove2} -$c bind box3 <1> {set demo_arrowInfo(motionProc) arrowMove3} -$c bind box <B1-Motion> "\$demo_arrowInfo(motionProc) $c %x %y" -bind $c <Any-ButtonRelease-1> "arrowSetup $c" - -# arrowMove1 -- -# This procedure is called for each mouse motion event on box1 (the -# one at the vertex of the arrow). It updates the controlling parameters -# for the line and arrowhead. -# -# Arguments: -# c - The name of the canvas window. -# x, y - The coordinates of the mouse. - -proc arrowMove1 {c x y} { - upvar #0 demo_arrowInfo v - set newA [expr {($v(x2)+5-round([$c canvasx $x]))/10}] - if {$newA < 0} { - set newA 0 - } - if {$newA > 25} { - set newA 25 - } - if {$newA != $v(a)} { - $c move box1 [expr {10*($v(a)-$newA)}] 0 - set v(a) $newA - } -} - -# arrowMove2 -- -# This procedure is called for each mouse motion event on box2 (the -# one at the trailing tip of the arrowhead). It updates the controlling -# parameters for the line and arrowhead. -# -# Arguments: -# c - The name of the canvas window. -# x, y - The coordinates of the mouse. - -proc arrowMove2 {c x y} { - upvar #0 demo_arrowInfo v - set newB [expr {($v(x2)+5-round([$c canvasx $x]))/10}] - if {$newB < 0} { - set newB 0 - } - if {$newB > 25} { - set newB 25 - } - set newC [expr {($v(y)+5-round([$c canvasy $y])-5*$v(width))/10}] - if {$newC < 0} { - set newC 0 - } - if {$newC > 20} { - set newC 20 - } - if {($newB != $v(b)) || ($newC != $v(c))} { - $c move box2 [expr {10*($v(b)-$newB)}] [expr {10*($v(c)-$newC)}] - set v(b) $newB - set v(c) $newC - } -} - -# arrowMove3 -- -# This procedure is called for each mouse motion event on box3 (the -# one that controls the thickness of the line). It updates the -# controlling parameters for the line and arrowhead. -# -# Arguments: -# c - The name of the canvas window. -# x, y - The coordinates of the mouse. - -proc arrowMove3 {c x y} { - upvar #0 demo_arrowInfo v - set newWidth [expr {($v(y)+2-round([$c canvasy $y]))/5}] - if {$newWidth < 0} { - set newWidth 0 - } - if {$newWidth > 20} { - set newWidth 20 - } - if {$newWidth != $v(width)} { - $c move box3 0 [expr {5*($v(width)-$newWidth)}] - set v(width) $newWidth - } -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/bind.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/bind.tcl @@ -1,78 +0,0 @@ -# bind.tcl -- -# -# This demonstration script creates a text widget with bindings set -# up for hypertext-like effects. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .bind -catch {destroy $w} -toplevel $w -wm title $w "Text Demonstration - Tag Bindings" -wm iconname $w "bind" -positionWindow $w - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -text $w.text -yscrollcommand "$w.scroll set" -setgrid true \ - -width 60 -height 24 -font $font -wrap word -ttk::scrollbar $w.scroll -command "$w.text yview" -pack $w.scroll -side right -fill y -pack $w.text -expand yes -fill both - -# Set up display styles. - -if {[winfo depth $w] > 1} { - set bold "-background #43ce80 -relief raised -borderwidth 1" - set normal "-background {} -relief flat" -} else { - set bold "-foreground white -background black" - set normal "-foreground {} -background {}" -} - -# Add text to widget. - -$w.text insert 0.0 {\ -The same tag mechanism that controls display styles in text widgets can also be used to associate Tcl commands with regions of text, so that mouse or keyboard actions on the text cause particular Tcl commands to be invoked. For example, in the text below the descriptions of the canvas demonstrations have been tagged. When you move the mouse over a demo description the description lights up, and when you press button 1 over a description then that particular demonstration is invoked. - -} -$w.text insert end \ -{1. Samples of all the different types of items that can be created in canvas widgets.} d1 -$w.text insert end \n\n -$w.text insert end \ -{2. A simple two-dimensional plot that allows you to adjust the positions of the data points.} d2 -$w.text insert end \n\n -$w.text insert end \ -{3. Anchoring and justification modes for text items.} d3 -$w.text insert end \n\n -$w.text insert end \ -{4. An editor for arrow-head shapes for line items.} d4 -$w.text insert end \n\n -$w.text insert end \ -{5. A ruler with facilities for editing tab stops.} d5 -$w.text insert end \n\n -$w.text insert end \ -{6. A grid that demonstrates how canvases can be scrolled.} d6 - -# Create bindings for tags. - -foreach tag {d1 d2 d3 d4 d5 d6} { - $w.text tag bind $tag <Any-Enter> "$w.text tag configure $tag $bold" - $w.text tag bind $tag <Any-Leave> "$w.text tag configure $tag $normal" -} -# Main widget program sets variable tk_demoDirectory -$w.text tag bind d1 <1> {source [file join $tk_demoDirectory items.tcl]} -$w.text tag bind d2 <1> {source [file join $tk_demoDirectory plot.tcl]} -$w.text tag bind d3 <1> {source [file join $tk_demoDirectory ctext.tcl]} -$w.text tag bind d4 <1> {source [file join $tk_demoDirectory arrow.tcl]} -$w.text tag bind d5 <1> {source [file join $tk_demoDirectory ruler.tcl]} -$w.text tag bind d6 <1> {source [file join $tk_demoDirectory cscroll.tcl]} - -$w.text mark set insert 0.0 -$w.text configure -state disabled diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/bitmap.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/bitmap.tcl @@ -1,52 +0,0 @@ -# bitmap.tcl -- -# -# This demonstration script creates a toplevel window that displays -# all of Tk's built-in bitmaps. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -# bitmapRow -- -# Create a row of bitmap items in a window. -# -# Arguments: -# w - The window that is to contain the row. -# args - The names of one or more bitmaps, which will be displayed -# in a new row across the bottom of w along with their -# names. - -proc bitmapRow {w args} { - frame $w - pack $w -side top -fill both - set i 0 - foreach bitmap $args { - frame $w.$i - pack $w.$i -side left -fill both -pady .25c -padx .25c - label $w.$i.bitmap -bitmap $bitmap - label $w.$i.label -text $bitmap -width 9 - pack $w.$i.label $w.$i.bitmap -side bottom - incr i - } -} - -set w .bitmap -catch {destroy $w} -toplevel $w -wm title $w "Bitmap Demonstration" -wm iconname $w "bitmap" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "This window displays all of Tk's built-in bitmaps, along with the names you can use for them in Tcl scripts." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -frame $w.frame -bitmapRow $w.frame.0 error gray12 gray25 gray50 gray75 -bitmapRow $w.frame.1 hourglass info question questhead warning -pack $w.frame -side top -expand yes -fill both diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/browse b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/browse @@ -1,66 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish8.6 "$0" ${1+"$@"} - -# browse -- -# This script generates a directory browser, which lists the working -# directory and allows you to open files or subdirectories by -# double-clicking. - -package require Tk - -# Create a scrollbar on the right side of the main window and a listbox -# on the left side. - -scrollbar .scroll -command ".list yview" -pack .scroll -side right -fill y -listbox .list -yscroll ".scroll set" -relief sunken -width 20 -height 20 \ - -setgrid yes -pack .list -side left -fill both -expand yes -wm minsize . 1 1 - -# The procedure below is invoked to open a browser on a given file; if the -# file is a directory then another instance of this program is invoked; if -# the file is a regular file then the Mx editor is invoked to display -# the file. - -set browseScript [file join [pwd] $argv0] -proc browse {dir file} { - global env browseScript - if {[string compare $dir "."] != 0} {set file $dir/$file} - switch [file type $file] { - directory { - exec [info nameofexecutable] $browseScript $file & - } - file { - if {[info exists env(EDITOR)]} { - eval exec $env(EDITOR) $file & - } else { - exec xedit $file & - } - } - default { - puts stdout "\"$file\" isn't a directory or regular file" - } - } -} - -# Fill the listbox with a list of all the files in the directory. - -if {$argc>0} {set dir [lindex $argv 0]} else {set dir "."} -foreach i [lsort [glob * .* *.*]] { - if {[file type $i] eq "directory"} { - # Safe to do since it is still a directory. - append i / - } - .list insert end $i -} - -# Set up bindings for the browser. - -bind all <Control-c> {destroy .} -bind .list <Double-Button-1> {foreach i [selection get] {browse $dir $i}} - -# Local Variables: -# mode: tcl -# End: diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/button.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/button.tcl @@ -1,47 +0,0 @@ -# button.tcl -- -# -# This demonstration script creates a toplevel window containing -# several button widgets. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .button -catch {destroy $w} -toplevel $w -wm title $w "Button Demonstration" -wm iconname $w "button" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "If you click on any of the four buttons below, the background of the button area will change to the color indicated in the button. You can press Tab to move among the buttons, then press Space to invoke the current button." -pack $w.msg -side top - -## See Code / Dismiss buttons -pack [addSeeDismiss $w.buttons $w] -side bottom -fill x - -proc colorrefresh {w col} { - $w configure -bg $col - if {[tk windowingsystem] eq "aqua"} { - # set highlightbackground of all buttons in $w - set l [list $w] - while {[llength $l]} { - set l [concat [lassign $l b] [winfo children $b]] - if {[winfo class $b] eq "Button"} { - $b configure -highlightbackground $col - } - } - } -} - -button $w.b1 -text "Peach Puff" -width 10 \ - -command [list colorrefresh $w PeachPuff1] -button $w.b2 -text "Light Blue" -width 10 \ - -command [list colorrefresh $w LightBlue1] -button $w.b3 -text "Sea Green" -width 10 \ - -command [list colorrefresh $w SeaGreen2] -button $w.b4 -text "Yellow" -width 10 \ - -command [list colorrefresh $w Yellow1] -pack $w.b1 $w.b2 $w.b3 $w.b4 -side top -expand yes -pady 2 diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/check.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/check.tcl @@ -1,71 +0,0 @@ -# check.tcl -- -# -# This demonstration script creates a toplevel window containing -# several checkbuttons. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .check -catch {destroy $w} -toplevel $w -wm title $w "Checkbutton Demonstration" -wm iconname $w "check" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "Four checkbuttons are displayed below. If you click on a button, it will toggle the button's selection state and set a Tcl variable to a value indicating the state of the checkbutton. The first button also follows the state of the other three. If only some of the three are checked, the first button will display the tri-state mode. Click the \"See Variables\" button to see the current values of the variables." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w [list safety wipers brakes sober]] -pack $btns -side bottom -fill x - -checkbutton $w.b0 -text "Safety Check" -variable safety -relief flat \ - -onvalue "all" \ - -offvalue "none" \ - -tristatevalue "partial" -checkbutton $w.b1 -text "Wipers OK" -variable wipers -relief flat -checkbutton $w.b2 -text "Brakes OK" -variable brakes -relief flat -checkbutton $w.b3 -text "Driver Sober" -variable sober -relief flat -pack $w.b0 -side top -pady 2 -anchor w -pack $w.b1 $w.b2 $w.b3 -side top -pady 2 -anchor w -padx 15 - -## This code makes $w.b0 function as a tri-state button; it's not -## needed at all for just straight yes/no buttons. - -set in_check 0 -proc tristate_check {n1 n2 op} { - global safety wipers brakes sober in_check - if {$in_check} { - return - } - set in_check 1 - if {$n1 eq "safety"} { - if {$safety eq "none"} { - set wipers 0 - set brakes 0 - set sober 0 - } elseif {$safety eq "all"} { - set wipers 1 - set brakes 1 - set sober 1 - } - } else { - if {$wipers == 1 && $brakes == 1 && $sober == 1} { - set safety all - } elseif {$wipers == 1 || $brakes == 1 || $sober == 1} { - set safety partial - } else { - set safety none - } - } - set in_check 0 -} - -trace variable wipers w tristate_check -trace variable brakes w tristate_check -trace variable sober w tristate_check -trace variable safety w tristate_check diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/clrpick.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/clrpick.tcl @@ -1,54 +0,0 @@ -# clrpick.tcl -- -# -# This demonstration script prompts the user to select a color. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .clrpick -catch {destroy $w} -toplevel $w -wm title $w "Color Selection Dialog" -wm iconname $w "colors" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "Press the buttons below to choose the foreground and background colors for the widgets in this window." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -button $w.back -text "Set background color ..." \ - -command \ - "setColor $w $w.back background {-background -highlightbackground}" -button $w.fore -text "Set foreground color ..." \ - -command \ - "setColor $w $w.back foreground -foreground" - -pack $w.back $w.fore -side top -anchor c -pady 2m - -proc setColor {w button name options} { - grab $w - set initialColor [$button cget -$name] - set color [tk_chooseColor -title "Choose a $name color" -parent $w \ - -initialcolor $initialColor] - if {[string compare $color ""]} { - setColor_helper $w $options $color - } - grab release $w -} - -proc setColor_helper {w options color} { - foreach option $options { - catch { - $w config $option $color - } - } - foreach child [winfo children $w] { - setColor_helper $child $options $color - } -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/colors.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/colors.tcl @@ -1,99 +0,0 @@ -# colors.tcl -- -# -# This demonstration script creates a listbox widget that displays -# many of the colors from the X color database. You can click on -# a color to change the application's palette. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .colors -catch {destroy $w} -toplevel $w -wm title $w "Listbox Demonstration (colors)" -wm iconname $w "Listbox" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "A listbox containing several color names is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. If you double-click button 1 on a color, then the application's color palette will be set to match that color" -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -frame $w.frame -borderwidth 10 -pack $w.frame -side top -expand yes -fill y - -scrollbar $w.frame.scroll -command "$w.frame.list yview" -listbox $w.frame.list -yscroll "$w.frame.scroll set" \ - -width 20 -height 16 -setgrid 1 -pack $w.frame.list $w.frame.scroll -side left -fill y -expand 1 - -bind $w.frame.list <Double-1> { - tk_setPalette [selection get] -} -$w.frame.list insert 0 gray60 gray70 gray80 gray85 gray90 gray95 \ - snow1 snow2 snow3 snow4 seashell1 seashell2 \ - seashell3 seashell4 AntiqueWhite1 AntiqueWhite2 AntiqueWhite3 \ - AntiqueWhite4 bisque1 bisque2 bisque3 bisque4 PeachPuff1 \ - PeachPuff2 PeachPuff3 PeachPuff4 NavajoWhite1 NavajoWhite2 \ - NavajoWhite3 NavajoWhite4 LemonChiffon1 LemonChiffon2 \ - LemonChiffon3 LemonChiffon4 cornsilk1 cornsilk2 cornsilk3 \ - cornsilk4 ivory1 ivory2 ivory3 ivory4 honeydew1 honeydew2 \ - honeydew3 honeydew4 LavenderBlush1 LavenderBlush2 \ - LavenderBlush3 LavenderBlush4 MistyRose1 MistyRose2 \ - MistyRose3 MistyRose4 azure1 azure2 azure3 azure4 \ - SlateBlue1 SlateBlue2 SlateBlue3 SlateBlue4 RoyalBlue1 \ - RoyalBlue2 RoyalBlue3 RoyalBlue4 blue1 blue2 blue3 blue4 \ - DodgerBlue1 DodgerBlue2 DodgerBlue3 DodgerBlue4 SteelBlue1 \ - SteelBlue2 SteelBlue3 SteelBlue4 DeepSkyBlue1 DeepSkyBlue2 \ - DeepSkyBlue3 DeepSkyBlue4 SkyBlue1 SkyBlue2 SkyBlue3 \ - SkyBlue4 LightSkyBlue1 LightSkyBlue2 LightSkyBlue3 \ - LightSkyBlue4 SlateGray1 SlateGray2 SlateGray3 SlateGray4 \ - LightSteelBlue1 LightSteelBlue2 LightSteelBlue3 \ - LightSteelBlue4 LightBlue1 LightBlue2 LightBlue3 \ - LightBlue4 LightCyan1 LightCyan2 LightCyan3 LightCyan4 \ - PaleTurquoise1 PaleTurquoise2 PaleTurquoise3 PaleTurquoise4 \ - CadetBlue1 CadetBlue2 CadetBlue3 CadetBlue4 turquoise1 \ - turquoise2 turquoise3 turquoise4 cyan1 cyan2 cyan3 cyan4 \ - DarkSlateGray1 DarkSlateGray2 DarkSlateGray3 \ - DarkSlateGray4 aquamarine1 aquamarine2 aquamarine3 \ - aquamarine4 DarkSeaGreen1 DarkSeaGreen2 DarkSeaGreen3 \ - DarkSeaGreen4 SeaGreen1 SeaGreen2 SeaGreen3 SeaGreen4 \ - PaleGreen1 PaleGreen2 PaleGreen3 PaleGreen4 SpringGreen1 \ - SpringGreen2 SpringGreen3 SpringGreen4 green1 green2 \ - green3 green4 chartreuse1 chartreuse2 chartreuse3 \ - chartreuse4 OliveDrab1 OliveDrab2 OliveDrab3 OliveDrab4 \ - DarkOliveGreen1 DarkOliveGreen2 DarkOliveGreen3 \ - DarkOliveGreen4 khaki1 khaki2 khaki3 khaki4 \ - LightGoldenrod1 LightGoldenrod2 LightGoldenrod3 \ - LightGoldenrod4 LightYellow1 LightYellow2 LightYellow3 \ - LightYellow4 yellow1 yellow2 yellow3 yellow4 gold1 gold2 \ - gold3 gold4 goldenrod1 goldenrod2 goldenrod3 goldenrod4 \ - DarkGoldenrod1 DarkGoldenrod2 DarkGoldenrod3 DarkGoldenrod4 \ - RosyBrown1 RosyBrown2 RosyBrown3 RosyBrown4 IndianRed1 \ - IndianRed2 IndianRed3 IndianRed4 sienna1 sienna2 sienna3 \ - sienna4 burlywood1 burlywood2 burlywood3 burlywood4 wheat1 \ - wheat2 wheat3 wheat4 tan1 tan2 tan3 tan4 chocolate1 \ - chocolate2 chocolate3 chocolate4 firebrick1 firebrick2 \ - firebrick3 firebrick4 brown1 brown2 brown3 brown4 salmon1 \ - salmon2 salmon3 salmon4 LightSalmon1 LightSalmon2 \ - LightSalmon3 LightSalmon4 orange1 orange2 orange3 orange4 \ - DarkOrange1 DarkOrange2 DarkOrange3 DarkOrange4 coral1 \ - coral2 coral3 coral4 tomato1 tomato2 tomato3 tomato4 \ - OrangeRed1 OrangeRed2 OrangeRed3 OrangeRed4 red1 red2 red3 \ - red4 DeepPink1 DeepPink2 DeepPink3 DeepPink4 HotPink1 \ - HotPink2 HotPink3 HotPink4 pink1 pink2 pink3 pink4 \ - LightPink1 LightPink2 LightPink3 LightPink4 PaleVioletRed1 \ - PaleVioletRed2 PaleVioletRed3 PaleVioletRed4 maroon1 \ - maroon2 maroon3 maroon4 VioletRed1 VioletRed2 VioletRed3 \ - VioletRed4 magenta1 magenta2 magenta3 magenta4 orchid1 \ - orchid2 orchid3 orchid4 plum1 plum2 plum3 plum4 \ - MediumOrchid1 MediumOrchid2 MediumOrchid3 MediumOrchid4 \ - DarkOrchid1 DarkOrchid2 DarkOrchid3 DarkOrchid4 purple1 \ - purple2 purple3 purple4 MediumPurple1 MediumPurple2 \ - MediumPurple3 MediumPurple4 thistle1 thistle2 thistle3 \ - thistle4 diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/combo.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/combo.tcl @@ -1,61 +0,0 @@ -# combo.tcl -- -# -# This demonstration script creates several combobox widgets. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .combo -catch {destroy $w} -toplevel $w -wm title $w "Combobox Demonstration" -wm iconname $w "combo" -positionWindow $w - -ttk::label $w.msg -font $font -wraplength 5i -justify left -text "Three different\ - combo-boxes are displayed below. You can add characters to the first\ - one by pointing, clicking and typing, just as with an entry; pressing\ - Return will cause the current value to be added to the list that is\ - selectable from the drop-down list, and you can choose other values\ - by pressing the Down key, using the arrow keys to pick another one,\ - and pressing Return again. The second combo-box is fixed to a\ - particular value, and cannot be modified at all. The third one only\ - allows you to select values from its drop-down list of Australian\ - cities." -pack $w.msg -side top -fill x - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w {firstValue secondValue ozCity}] -pack $btns -side bottom -fill x - -ttk::frame $w.f -pack $w.f -fill both -expand 1 -set w $w.f - -set australianCities { - Canberra Sydney Melbourne Perth Adelaide Brisbane - Hobart Darwin "Alice Springs" -} -set secondValue unchangable -set ozCity Sydney - -ttk::labelframe $w.c1 -text "Fully Editable" -ttk::combobox $w.c1.c -textvariable firstValue -ttk::labelframe $w.c2 -text Disabled -ttk::combobox $w.c2.c -textvariable secondValue -state disabled -ttk::labelframe $w.c3 -text "Defined List Only" -ttk::combobox $w.c3.c -textvariable ozCity -state readonly \ - -values $australianCities -bind $w.c1.c <Return> { - if {[%W get] ni [%W cget -values]} { - %W configure -values [concat [%W cget -values] [list [%W get]]] - } -} - -pack $w.c1 $w.c2 $w.c3 -side top -pady 5 -padx 10 -pack $w.c1.c -pady 5 -padx 10 -pack $w.c2.c -pady 5 -padx 10 -pack $w.c3.c -pady 5 -padx 10 diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/cscroll.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/cscroll.tcl @@ -1,108 +0,0 @@ -# cscroll.tcl -- -# -# This demonstration script creates a simple canvas that can be -# scrolled in two dimensions. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .cscroll -catch {destroy $w} -toplevel $w -wm title $w "Scrollable Canvas Demonstration" -wm iconname $w "cscroll" -positionWindow $w -set c $w.c - -label $w.msg -font $font -wraplength 4i -justify left -text "This window displays a canvas widget that can be scrolled either using the scrollbars or by dragging with button 2 in the canvas. If you click button 1 on one of the rectangles, its indices will be printed on stdout." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -frame $w.grid -scrollbar $w.hscroll -orient horiz -command "$c xview" -scrollbar $w.vscroll -command "$c yview" -canvas $c -relief sunken -borderwidth 2 -scrollregion {-11c -11c 50c 20c} \ - -xscrollcommand "$w.hscroll set" \ - -yscrollcommand "$w.vscroll set" -pack $w.grid -expand yes -fill both -padx 1 -pady 1 -grid rowconfig $w.grid 0 -weight 1 -minsize 0 -grid columnconfig $w.grid 0 -weight 1 -minsize 0 - -grid $c -padx 1 -in $w.grid -pady 1 \ - -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news -grid $w.vscroll -in $w.grid -padx 1 -pady 1 \ - -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news -grid $w.hscroll -in $w.grid -padx 1 -pady 1 \ - -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news - - -set bg [lindex [$c config -bg] 4] -for {set i 0} {$i < 20} {incr i} { - set x [expr {-10 + 3*$i}] - for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} { - $c create rect ${x}c ${y}c [expr {$x+2}]c [expr {$y+2}]c \ - -outline black -fill $bg -tags rect - $c create text [expr {$x+1}]c [expr {$y+1}]c -text "$i,$j" \ - -anchor center -tags text - } -} - -$c bind all <Any-Enter> "scrollEnter $c" -$c bind all <Any-Leave> "scrollLeave $c" -$c bind all <1> "scrollButton $c" -bind $c <2> "$c scan mark %x %y" -bind $c <B2-Motion> "$c scan dragto %x %y" -if {[tk windowingsystem] eq "aqua"} { - bind $c <MouseWheel> { - %W yview scroll [expr {- (%D)}] units - } - bind $c <Option-MouseWheel> { - %W yview scroll [expr {-10 * (%D)}] units - } - bind $c <Shift-MouseWheel> { - %W xview scroll [expr {- (%D)}] units - } - bind $c <Shift-Option-MouseWheel> { - %W xview scroll [expr {-10 * (%D)}] units - } -} - -proc scrollEnter canvas { - global oldFill - set id [$canvas find withtag current] - if {[lsearch [$canvas gettags current] text] >= 0} { - set id [expr {$id-1}] - } - set oldFill [lindex [$canvas itemconfig $id -fill] 4] - if {[winfo depth $canvas] > 1} { - $canvas itemconfigure $id -fill SeaGreen1 - } else { - $canvas itemconfigure $id -fill black - $canvas itemconfigure [expr {$id+1}] -fill white - } -} - -proc scrollLeave canvas { - global oldFill - set id [$canvas find withtag current] - if {[lsearch [$canvas gettags current] text] >= 0} { - set id [expr {$id-1}] - } - $canvas itemconfigure $id -fill $oldFill - $canvas itemconfigure [expr {$id+1}] -fill black -} - -proc scrollButton canvas { - global oldFill - set id [$canvas find withtag current] - if {[lsearch [$canvas gettags current] text] < 0} { - set id [expr {$id+1}] - } - puts stdout "You buttoned at [lindex [$canvas itemconf $id -text] 4]" -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/ctext.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/ctext.tcl @@ -1,172 +0,0 @@ -# ctext.tcl -- -# -# This demonstration script creates a canvas widget with a text -# item that can be edited and reconfigured in various ways. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .ctext -catch {destroy $w} -toplevel $w -wm title $w "Canvas Text Demonstration" -wm iconname $w "Text" -positionWindow $w -set c $w.c - -label $w.msg -font $font -wraplength 5i -justify left -text "This window displays a string of text to demonstrate the text facilities of canvas widgets. You can click in the boxes to adjust the position of the text relative to its positioning point or change its justification, and on a pie slice to change its angle. The text also supports the following simple bindings for editing: - 1. You can point, click, and type. - 2. You can also select with button 1. - 3. You can copy the selection to the mouse position with button 2. - 4. Backspace and Control+h delete the selection if there is one; - otherwise they delete the character just before the insertion cursor. - 5. Delete deletes the selection if there is one; otherwise it deletes - the character just after the insertion cursor." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -canvas $c -relief flat -borderwidth 0 -width 500 -height 350 -pack $w.c -side top -expand yes -fill both - -set textFont {Helvetica 24} - -$c create rectangle 245 195 255 205 -outline black -fill red - -# First, create the text item and give it bindings so it can be edited. - -$c addtag text withtag [$c create text 250 200 -text "This is just a string of text to demonstrate the text facilities of canvas widgets. Bindings have been been defined to support editing (see above)." -width 440 -anchor n -font $textFont -justify left] -$c bind text <1> "textB1Press $c %x %y" -$c bind text <B1-Motion> "textB1Move $c %x %y" -$c bind text <Shift-1> "$c select adjust current @%x,%y" -$c bind text <Shift-B1-Motion> "textB1Move $c %x %y" -$c bind text <KeyPress> "textInsert $c %A" -$c bind text <Return> "textInsert $c \\n" -$c bind text <Control-h> "textBs $c" -$c bind text <BackSpace> "textBs $c" -$c bind text <Delete> "textDel $c" -$c bind text <2> "textPaste $c @%x,%y" - -# Next, create some items that allow the text's anchor position -# to be edited. - -proc mkTextConfigBox {w x y option value color} { - set item [$w create rect $x $y [expr {$x+30}] [expr {$y+30}] \ - -outline black -fill $color -width 1] - $w bind $item <1> "$w itemconf text $option $value" - $w addtag config withtag $item -} -proc mkTextConfigPie {w x y a option value color} { - set item [$w create arc $x $y [expr {$x+90}] [expr {$y+90}] \ - -start [expr {$a-15}] -extent 30 -outline black -fill $color \ - -width 1] - $w bind $item <1> "$w itemconf text $option $value" - $w addtag config withtag $item -} - -set x 50 -set y 50 -set color LightSkyBlue1 -mkTextConfigBox $c $x $y -anchor se $color -mkTextConfigBox $c [expr {$x+30}] [expr {$y }] -anchor s $color -mkTextConfigBox $c [expr {$x+60}] [expr {$y }] -anchor sw $color -mkTextConfigBox $c [expr {$x }] [expr {$y+30}] -anchor e $color -mkTextConfigBox $c [expr {$x+30}] [expr {$y+30}] -anchor center $color -mkTextConfigBox $c [expr {$x+60}] [expr {$y+30}] -anchor w $color -mkTextConfigBox $c [expr {$x }] [expr {$y+60}] -anchor ne $color -mkTextConfigBox $c [expr {$x+30}] [expr {$y+60}] -anchor n $color -mkTextConfigBox $c [expr {$x+60}] [expr {$y+60}] -anchor nw $color -set item [$c create rect \ - [expr {$x+40}] [expr {$y+40}] [expr {$x+50}] [expr {$y+50}] \ - -outline black -fill red] -$c bind $item <1> "$c itemconf text -anchor center" -$c create text [expr {$x+45}] [expr {$y-5}] \ - -text {Text Position} -anchor s -font {Times 20} -fill brown - -# Now create some items that allow the text's angle to be changed. - -set x 205 -set y 50 -set color Yellow -mkTextConfigPie $c $x $y 0 -angle 90 $color -mkTextConfigPie $c $x $y 30 -angle 120 $color -mkTextConfigPie $c $x $y 60 -angle 150 $color -mkTextConfigPie $c $x $y 90 -angle 180 $color -mkTextConfigPie $c $x $y 120 -angle 210 $color -mkTextConfigPie $c $x $y 150 -angle 240 $color -mkTextConfigPie $c $x $y 180 -angle 270 $color -mkTextConfigPie $c $x $y 210 -angle 300 $color -mkTextConfigPie $c $x $y 240 -angle 330 $color -mkTextConfigPie $c $x $y 270 -angle 0 $color -mkTextConfigPie $c $x $y 300 -angle 30 $color -mkTextConfigPie $c $x $y 330 -angle 60 $color -$c create text [expr {$x+45}] [expr {$y-5}] \ - -text {Text Angle} -anchor s -font {Times 20} -fill brown - -# Lastly, create some items that allow the text's justification to be -# changed. - -set x 350 -set y 50 -set color SeaGreen2 -mkTextConfigBox $c $x $y -justify left $color -mkTextConfigBox $c [expr {$x+30}] $y -justify center $color -mkTextConfigBox $c [expr {$x+60}] $y -justify right $color -$c create text [expr {$x+45}] [expr {$y-5}] \ - -text {Justification} -anchor s -font {Times 20} -fill brown - -$c bind config <Enter> "textEnter $c" -$c bind config <Leave> "$c itemconf current -fill \$textConfigFill" - -set textConfigFill {} - -proc textEnter {w} { - global textConfigFill - set textConfigFill [lindex [$w itemconfig current -fill] 4] - $w itemconfig current -fill black -} - -proc textInsert {w string} { - if {$string == ""} { - return - } - catch {$w dchars text sel.first sel.last} - $w insert text insert $string -} - -proc textPaste {w pos} { - catch { - $w insert text $pos [selection get] - } -} - -proc textB1Press {w x y} { - $w icursor current @$x,$y - $w focus current - focus $w - $w select from current @$x,$y -} - -proc textB1Move {w x y} { - $w select to current @$x,$y -} - -proc textBs {w} { - if {![catch {$w dchars text sel.first sel.last}]} { - return - } - set char [expr {[$w index text insert] - 1}] - if {$char >= 0} {$w dchar text $char} -} - -proc textDel {w} { - if {![catch {$w dchars text sel.first sel.last}]} { - return - } - $w dchars text insert -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/dialog1.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/dialog1.tcl @@ -1,13 +0,0 @@ -# dialog1.tcl -- -# -# This demonstration script creates a dialog box with a local grab. - -after idle {.dialog1.msg configure -wraplength 4i} -set i [tk_dialog .dialog1 "Dialog with local grab" {This is a modal dialog box. It uses Tk's "grab" command to create a "local grab" on the dialog box. The grab prevents any pointer-related events from getting to any other windows in the application until you have answered the dialog by invoking one of the buttons below. However, you can still interact with other applications.} \ -info 0 OK Cancel {Show Code}] - -switch $i { - 0 {puts "You pressed OK"} - 1 {puts "You pressed Cancel"} - 2 {showCode .dialog1} -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/dialog2.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/dialog2.tcl @@ -1,17 +0,0 @@ -# dialog2.tcl -- -# -# This demonstration script creates a dialog box with a global grab. - -after idle { - .dialog2.msg configure -wraplength 4i -} -after 100 { - grab -global .dialog2 -} -set i [tk_dialog .dialog2 "Dialog with global grab" {This dialog box uses a global grab, so it prevents you from interacting with anything on your display until you invoke one of the buttons below. Global grabs are almost always a bad idea; don't use them unless you're truly desperate.} warning 0 OK Cancel {Show Code}] - -switch $i { - 0 {puts "You pressed OK"} - 1 {puts "You pressed Cancel"} - 2 {showCode .dialog2} -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/en.msg b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/en.msg @@ -1,97 +0,0 @@ -::msgcat::mcset en "Widget Demonstration" -::msgcat::mcset en "tkWidgetDemo" -::msgcat::mcset en "&File" -::msgcat::mcset en "About..." -::msgcat::mcset en "&About..." -::msgcat::mcset en "<F1>" -::msgcat::mcset en "&Quit" -::msgcat::mcset en "Meta+Q" ;# Displayed hotkey -::msgcat::mcset en "Meta-q" ;# Actual binding sequence -::msgcat::mcset en "Ctrl+Q" ;# Displayed hotkey -::msgcat::mcset en "Control-q" ;# Actual binding sequence -::msgcat::mcset en "Variable values" -::msgcat::mcset en "Variable values:" -::msgcat::mcset en "OK" -::msgcat::mcset en "Run the \"%s\" sample program" -::msgcat::mcset en "Dismiss" -::msgcat::mcset en "Rerun Demo" -::msgcat::mcset en "Demo code: %s" -::msgcat::mcset en "About Widget Demo" -::msgcat::mcset en "Tk widget demonstration application" -::msgcat::mcset en "Copyright © %s" -::msgcat::mcset en " - @@title - Tk Widget Demonstrations - @@newline - @@normal - @@newline - - This application provides a front end for several short scripts - that demonstrate what you can do with Tk widgets. Each of the - numbered lines below describes a demonstration; you can click on - it to invoke the demonstration. Once the demonstration window - appears, you can click the - @@bold - See Code - @@normal - button to see the Tcl/Tk code that created the demonstration. If - you wish, you can edit the code and click the - @@bold - Rerun Demo - @@normal - button in the code window to reinvoke the demonstration with the - modified code. - @@newline -" -::msgcat::mcset en "Labels, buttons, checkbuttons, and radiobuttons" -::msgcat::mcset en "Labels (text and bitmaps)" -::msgcat::mcset en "Labels and UNICODE text" -::msgcat::mcset en "Buttons" -::msgcat::mcset en "Check-buttons (select any of a group)" -::msgcat::mcset en "Radio-buttons (select one of a group)" -::msgcat::mcset en "A 15-puzzle game made out of buttons" -::msgcat::mcset en "Iconic buttons that use bitmaps" -::msgcat::mcset en "Two labels displaying images" -::msgcat::mcset en "A simple user interface for viewing images" -::msgcat::mcset en "Labelled frames" -::msgcat::mcset en "Listboxes" -::msgcat::mcset en "The 50 states" -::msgcat::mcset en "Colors: change the color scheme for the application" -::msgcat::mcset en "A collection of famous and infamous sayings" -::msgcat::mcset en "Entries and Spin-boxes" -::msgcat::mcset en "Entries without scrollbars" -::msgcat::mcset en "Entries with scrollbars" -::msgcat::mcset en "Validated entries and password fields" -::msgcat::mcset en "Spin-boxes" -::msgcat::mcset en "Simple Rolodex-like form" -::msgcat::mcset en "Text" -::msgcat::mcset en "Basic editable text" -::msgcat::mcset en "Text display styles" -::msgcat::mcset en "Hypertext (tag bindings)" -::msgcat::mcset en "A text widget with embedded windows" -::msgcat::mcset en "A search tool built with a text widget" -::msgcat::mcset en "Canvases" -::msgcat::mcset en "The canvas item types" -::msgcat::mcset en "A simple 2-D plot" -::msgcat::mcset en "Text items in canvases" -::msgcat::mcset en "An editor for arrowheads on canvas lines" -::msgcat::mcset en "A ruler with adjustable tab stops" -::msgcat::mcset en "A building floor plan" -::msgcat::mcset en "A simple scrollable canvas" -::msgcat::mcset en "Scales" -::msgcat::mcset en "Horizontal scale" -::msgcat::mcset en "Vertical scale" -::msgcat::mcset en "Paned Windows" -::msgcat::mcset en "Horizontal paned window" -::msgcat::mcset en "Vertical paned window" -::msgcat::mcset en "Menus" -::msgcat::mcset en "Menus and cascades (sub-menus)" -::msgcat::mcset en "Menu-buttons" -::msgcat::mcset en "Common Dialogs" -::msgcat::mcset en "Message boxes" -::msgcat::mcset en "File selection dialog" -::msgcat::mcset en "Color picker" -::msgcat::mcset en "Miscellaneous" -::msgcat::mcset en "The built-in bitmaps" -::msgcat::mcset en "A dialog box with a local grab" -::msgcat::mcset en "A dialog box with a global grab" diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/entry1.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/entry1.tcl @@ -1,34 +0,0 @@ -# entry1.tcl -- -# -# This demonstration script creates several entry widgets without -# scrollbars. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .entry1 -catch {destroy $w} -toplevel $w -wm title $w "Entry Demonstration (no scrollbars)" -wm iconname $w "entry1" -positionWindow $w - -label $w.msg -font $font -wraplength 5i -justify left -text "Three different entries are displayed below. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse button2 pressed." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -entry $w.e1 -entry $w.e2 -entry $w.e3 -pack $w.e1 $w.e2 $w.e3 -side top -pady 5 -padx 10 -fill x - -$w.e1 insert 0 "Initial value" -$w.e2 insert end "This entry contains a long value, much too long " -$w.e2 insert end "to fit in the window at one time, so long in fact " -$w.e2 insert end "that you'll have to scan or scroll to see the end." diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/entry2.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/entry2.tcl @@ -1,46 +0,0 @@ -# entry2.tcl -- -# -# This demonstration script is the same as the entry1.tcl script -# except that it creates scrollbars for the entries. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .entry2 -catch {destroy $w} -toplevel $w -wm title $w "Entry Demonstration (with scrollbars)" -wm iconname $w "entry2" -positionWindow $w - -label $w.msg -font $font -wraplength 5i -justify left -text "Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries with the scrollbars, or by dragging with mouse button2 pressed." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -frame $w.frame -borderwidth 10 -pack $w.frame -side top -fill x -expand 1 - -entry $w.frame.e1 -xscrollcommand "$w.frame.s1 set" -ttk::scrollbar $w.frame.s1 -orient horiz -command \ - "$w.frame.e1 xview" -frame $w.frame.spacer1 -width 20 -height 10 -entry $w.frame.e2 -xscrollcommand "$w.frame.s2 set" -ttk::scrollbar $w.frame.s2 -orient horiz -command \ - "$w.frame.e2 xview" -frame $w.frame.spacer2 -width 20 -height 10 -entry $w.frame.e3 -xscrollcommand "$w.frame.s3 set" -ttk::scrollbar $w.frame.s3 -orient horiz -command \ - "$w.frame.e3 xview" -pack $w.frame.e1 $w.frame.s1 $w.frame.spacer1 $w.frame.e2 $w.frame.s2 \ - $w.frame.spacer2 $w.frame.e3 $w.frame.s3 -side top -fill x - -$w.frame.e1 insert 0 "Initial value" -$w.frame.e2 insert end "This entry contains a long value, much too long " -$w.frame.e2 insert end "to fit in the window at one time, so long in fact " -$w.frame.e2 insert end "that you'll have to scan or scroll to see the end." diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/entry3.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/entry3.tcl @@ -1,185 +0,0 @@ -# entry3.tcl -- -# -# This demonstration script creates several entry widgets whose -# permitted input is constrained in some way. It also shows off a -# password entry. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .entry3 -catch {destroy $w} -toplevel $w -wm title $w "Constrained Entry Demonstration" -wm iconname $w "entry3" -positionWindow $w - -label $w.msg -font $font -wraplength 5i -justify left -text "Four different\ - entries are displayed below. You can add characters by pointing,\ - clicking and typing, though each is constrained in what it will\ - accept. The first only accepts 32-bit integers or the empty string\ - (checking when focus leaves it) and will flash to indicate any\ - problem. The second only accepts strings with fewer than ten\ - characters and sounds the bell when an attempt to go over the limit\ - is made. The third accepts US phone numbers, mapping letters to\ - their digit equivalent and sounding the bell on encountering an\ - illegal character or if trying to type over a character that is not\ - a digit. The fourth is a password field that accepts up to eight\ - characters (silently ignoring further ones), and displaying them as\ - asterisk characters." - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -# focusAndFlash -- -# Error handler for entry widgets that forces the focus onto the -# widget and makes the widget flash by exchanging the foreground and -# background colours at intervals of 200ms (i.e. at approximately -# 2.5Hz). -# -# Arguments: -# W - Name of entry widget to flash -# fg - Initial foreground colour -# bg - Initial background colour -# count - Counter to control the number of times flashed - -proc focusAndFlash {W fg bg {count 9}} { - focus -force $W - if {$count<1} { - $W configure -foreground $fg -background $bg - } else { - if {$count%2} { - $W configure -foreground $bg -background $fg - } else { - $W configure -foreground $fg -background $bg - } - after 200 [list focusAndFlash $W $fg $bg [expr {$count-1}]] - } -} - -labelframe $w.l1 -text "Integer Entry" -# Alternatively try using {string is digit} for arbitrary length numbers, -# and not just 32-bit ones. -entry $w.l1.e -validate focus -vcmd {string is integer %P} -$w.l1.e configure -invalidcommand \ - "focusAndFlash %W [$w.l1.e cget -fg] [$w.l1.e cget -bg]" -pack $w.l1.e -fill x -expand 1 -padx 1m -pady 1m - -labelframe $w.l2 -text "Length-Constrained Entry" -entry $w.l2.e -validate key -invcmd bell -vcmd {expr {[string length %P]<10}} -pack $w.l2.e -fill x -expand 1 -padx 1m -pady 1m - -### PHONE NUMBER ENTRY ### -# Note that the source to this is quite a bit longer as the behaviour -# demonstrated is a lot more ambitious than with the others. - -# Initial content for the third entry widget -set entry3content "1-(000)-000-0000" -# Mapping from alphabetic characters to numbers. This is probably -# wrong, but it is the only mapping I have; the UK doesn't really go -# for associating letters with digits for some reason. -set phoneNumberMap {} -foreach {chars digit} {abc 2 def 3 ghi 4 jkl 5 mno 6 pqrs 7 tuv 8 wxyz 9} { - foreach char [split $chars ""] { - lappend phoneNumberMap $char $digit [string toupper $char] $digit - } -} - -# validatePhoneChange -- -# Checks that the replacement (mapped to a digit) of the given -# character in an entry widget at the given position will leave a -# valid phone number in the widget. -# -# W - The entry widget to validate -# vmode - The widget's validation mode -# idx - The index where replacement is to occur -# char - The character (or string, though that will always be -# refused) to be overwritten at that point. - -proc validatePhoneChange {W vmode idx char} { - global phoneNumberMap entry3content - if {$idx == -1} {return 1} - after idle [list $W configure -validate $vmode -invcmd bell] - if { - !($idx<3 || $idx==6 || $idx==7 || $idx==11 || $idx>15) && - [string match {[0-9A-Za-z]} $char] - } then { - $W delete $idx - $W insert $idx [string map $phoneNumberMap $char] - after idle [list phoneSkipRight $W -1] - return 1 - } - return 0 -} - -# phoneSkipLeft -- -# Skip over fixed characters in a phone-number string when moving left. -# -# Arguments: -# W - The entry widget containing the phone-number. - -proc phoneSkipLeft {W} { - set idx [$W index insert] - if {$idx == 8} { - # Skip back two extra characters - $W icursor [incr idx -2] - } elseif {$idx == 7 || $idx == 12} { - # Skip back one extra character - $W icursor [incr idx -1] - } elseif {$idx <= 3} { - # Can't move any further - bell - return -code break - } -} - -# phoneSkipRight -- -# Skip over fixed characters in a phone-number string when moving right. -# -# Arguments: -# W - The entry widget containing the phone-number. -# add - Offset to add to index before calculation (used by validation.) - -proc phoneSkipRight {W {add 0}} { - set idx [$W index insert] - if {$idx+$add == 5} { - # Skip forward two extra characters - $W icursor [incr idx 2] - } elseif {$idx+$add == 6 || $idx+$add == 10} { - # Skip forward one extra character - $W icursor [incr idx] - } elseif {$idx+$add == 15 && !$add} { - # Can't move any further - bell - return -code break - } -} - -labelframe $w.l3 -text "US Phone-Number Entry" -entry $w.l3.e -validate key -invcmd bell -textvariable entry3content \ - -vcmd {validatePhoneChange %W %v %i %S} -# Click to focus goes to the first editable character... -bind $w.l3.e <FocusIn> { - if {"%d" ne "NotifyAncestor"} { - %W icursor 3 - after idle {%W selection clear} - } -} -bind $w.l3.e <<PrevChar>> {phoneSkipLeft %W} -bind $w.l3.e <<NextChar>> {phoneSkipRight %W} -pack $w.l3.e -fill x -expand 1 -padx 1m -pady 1m - -labelframe $w.l4 -text "Password Entry" -entry $w.l4.e -validate key -show "*" -vcmd {expr {[string length %P]<=8}} -pack $w.l4.e -fill x -expand 1 -padx 1m -pady 1m - -lower [frame $w.mid] -grid $w.l1 $w.l2 -in $w.mid -padx 3m -pady 1m -sticky ew -grid $w.l3 $w.l4 -in $w.mid -padx 3m -pady 1m -sticky ew -grid columnconfigure $w.mid {0 1} -uniform 1 -pack $w.msg -side top -pack $w.mid -fill both -expand 1 diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/filebox.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/filebox.tcl @@ -1,81 +0,0 @@ -# filebox.tcl -- -# -# This demonstration script prompts the user to select a file. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .filebox -catch {destroy $w} -toplevel $w -wm title $w "File Selection Dialogs" -wm iconname $w "filebox" -positionWindow $w - -ttk::frame $w._bg -place $w._bg -x 0 -y 0 -relwidth 1 -relheight 1 - -ttk::label $w.msg -font $font -wraplength 4i -justify left -text "Enter a file name in the entry box or click on the \"Browse\" buttons to select a file name using the file selection dialog." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -foreach i {open save} { - set f [ttk::frame $w.$i] - ttk::label $f.lab -text "Select a file to $i: " -anchor e - ttk::entry $f.ent -width 20 - ttk::button $f.but -text "Browse ..." -command "fileDialog $w $f.ent $i" - pack $f.lab -side left - pack $f.ent -side left -expand yes -fill x - pack $f.but -side left - pack $f -fill x -padx 1c -pady 3 -} - -if {[tk windowingsystem] eq "x11"} { - ttk::checkbutton $w.strict -text "Use Motif Style Dialog" \ - -variable tk_strictMotif -onvalue 1 -offvalue 0 - pack $w.strict -anchor c - - # This binding ensures that we don't run the rest of the demos - # with motif style interactions - bind $w.strict <Destroy> {set tk_strictMotif 0} -} - -proc fileDialog {w ent operation} { - # Type names Extension(s) Mac File Type(s) - # - #--------------------------------------------------------- - set types { - {"Text files" {.txt .doc} } - {"Text files" {} TEXT} - {"Tcl Scripts" {.tcl} TEXT} - {"C Source Files" {.c .h} } - {"All Source Files" {.tcl .c .h} } - {"Image Files" {.gif} } - {"Image Files" {.jpeg .jpg} } - {"Image Files" "" {GIFF JPEG}} - {"All files" *} - } - if {$operation == "open"} { - global selected_type - if {![info exists selected_type]} { - set selected_type "Tcl Scripts" - } - set file [tk_getOpenFile -filetypes $types -parent $w \ - -typevariable selected_type] - puts "You selected filetype \"$selected_type\"" - } else { - set file [tk_getSaveFile -filetypes $types -parent $w \ - -initialfile Untitled -defaultextension .txt] - } - if {[string compare $file ""]} { - $ent delete 0 end - $ent insert 0 $file - $ent xview end - } -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/floor.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/floor.tcl @@ -1,1366 +0,0 @@ -# floor.tcl -- -# -# This demonstration script creates a canvas widet that displays the -# floorplan for DEC's Western Research Laboratory. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -# floorDisplay -- -# Recreate the floorplan display in the canvas given by "w". The -# floor given by "active" is displayed on top with its office structure -# visible. -# -# Arguments: -# w - Name of the canvas window. -# active - Number of active floor (1, 2, or 3). - -proc floorDisplay {w active} { - global floorLabels floorItems colors activeFloor - - if {$activeFloor == $active} { - return - } - - $w delete all - set activeFloor $active - - # First go through the three floors, displaying the backgrounds for - # each floor. - - bg1 $w $colors(bg1) $colors(outline1) - bg2 $w $colors(bg2) $colors(outline2) - bg3 $w $colors(bg3) $colors(outline3) - - # Raise the background for the active floor so that it's on top. - - $w raise floor$active - - # Create a dummy item just to mark this point in the display list, - # so we can insert highlights here. - - $w create rect 0 100 1 101 -fill {} -outline {} -tags marker - - # Add the walls and labels for the active floor, along with - # transparent polygons that define the rooms on the floor. - # Make sure that the room polygons are on top. - - catch {unset floorLabels} - catch {unset floorItems} - fg$active $w $colors(offices) - $w raise room - - # Offset the floors diagonally from each other. - - $w move floor1 2c 2c - $w move floor2 1c 1c - - # Create items for the room entry and its label. - - $w create window 600 100 -anchor w -window $w.entry - $w create text 600 100 -anchor e -text "Room: " - $w config -scrollregion [$w bbox all] -} - -# newRoom -- -# This procedure is invoked whenever the mouse enters a room -# in the floorplan. It changes tags so that the current room is -# highlighted. -# -# Arguments: -# w - The name of the canvas window. - -proc newRoom w { - global currentRoom floorLabels - - set id [$w find withtag current] - if {$id != ""} { - set currentRoom $floorLabels($id) - } - update idletasks -} - -# roomChanged -- -# This procedure is invoked whenever the currentRoom variable changes. -# It highlights the current room and unhighlights any previous room. -# -# Arguments: -# w - The canvas window displaying the floorplan. -# args - Not used. - -proc roomChanged {w args} { - global currentRoom floorItems colors - $w delete highlight - if {[catch {set item $floorItems($currentRoom)}]} { - return - } - set new [eval \ - "$w create polygon [$w coords $item] -fill $colors(active) \ - -tags highlight"] - $w raise $new marker -} - -# bg1 -- -# This procedure represents part of the floorplan database. When -# invoked, it instantiates the background information for the first -# floor. -# -# Arguments: -# w - The canvas window. -# fill - Fill color to use for the floor's background. -# outline - Color to use for the floor's outline. - -proc bg1 {w fill outline} { - $w create poly 347 80 349 82 351 84 353 85 363 92 375 99 386 104 \ - 386 129 398 129 398 162 484 162 484 129 559 129 559 133 725 \ - 133 725 129 802 129 802 389 644 389 644 391 559 391 559 327 \ - 508 327 508 311 484 311 484 278 395 278 395 288 400 288 404 \ - 288 409 290 413 292 418 297 421 302 422 309 421 318 417 325 \ - 411 330 405 332 397 333 344 333 340 334 336 336 335 338 332 \ - 342 331 347 332 351 334 354 336 357 341 359 340 360 335 363 \ - 331 365 326 366 304 366 304 355 258 355 258 387 60 387 60 391 \ - 0 391 0 337 3 337 3 114 8 114 8 25 30 25 30 5 93 5 98 5 104 7 \ - 110 10 116 16 119 20 122 28 123 32 123 68 220 68 220 34 221 \ - 22 223 17 227 13 231 8 236 4 242 2 246 0 260 0 283 1 300 5 \ - 321 14 335 22 348 25 365 29 363 39 358 48 352 56 337 70 \ - 344 76 347 80 \ - -tags {floor1 bg} -fill $fill - $w create line 386 129 398 129 -fill $outline -tags {floor1 bg} - $w create line 258 355 258 387 -fill $outline -tags {floor1 bg} - $w create line 60 387 60 391 -fill $outline -tags {floor1 bg} - $w create line 0 337 0 391 -fill $outline -tags {floor1 bg} - $w create line 60 391 0 391 -fill $outline -tags {floor1 bg} - $w create line 3 114 3 337 -fill $outline -tags {floor1 bg} - $w create line 258 387 60 387 -fill $outline -tags {floor1 bg} - $w create line 484 162 398 162 -fill $outline -tags {floor1 bg} - $w create line 398 162 398 129 -fill $outline -tags {floor1 bg} - $w create line 484 278 484 311 -fill $outline -tags {floor1 bg} - $w create line 484 311 508 311 -fill $outline -tags {floor1 bg} - $w create line 508 327 508 311 -fill $outline -tags {floor1 bg} - $w create line 559 327 508 327 -fill $outline -tags {floor1 bg} - $w create line 644 391 559 391 -fill $outline -tags {floor1 bg} - $w create line 644 389 644 391 -fill $outline -tags {floor1 bg} - $w create line 559 129 484 129 -fill $outline -tags {floor1 bg} - $w create line 484 162 484 129 -fill $outline -tags {floor1 bg} - $w create line 725 133 559 133 -fill $outline -tags {floor1 bg} - $w create line 559 129 559 133 -fill $outline -tags {floor1 bg} - $w create line 725 129 802 129 -fill $outline -tags {floor1 bg} - $w create line 802 389 802 129 -fill $outline -tags {floor1 bg} - $w create line 3 337 0 337 -fill $outline -tags {floor1 bg} - $w create line 559 391 559 327 -fill $outline -tags {floor1 bg} - $w create line 802 389 644 389 -fill $outline -tags {floor1 bg} - $w create line 725 133 725 129 -fill $outline -tags {floor1 bg} - $w create line 8 25 8 114 -fill $outline -tags {floor1 bg} - $w create line 8 114 3 114 -fill $outline -tags {floor1 bg} - $w create line 30 25 8 25 -fill $outline -tags {floor1 bg} - $w create line 484 278 395 278 -fill $outline -tags {floor1 bg} - $w create line 30 25 30 5 -fill $outline -tags {floor1 bg} - $w create line 93 5 30 5 -fill $outline -tags {floor1 bg} - $w create line 98 5 93 5 -fill $outline -tags {floor1 bg} - $w create line 104 7 98 5 -fill $outline -tags {floor1 bg} - $w create line 110 10 104 7 -fill $outline -tags {floor1 bg} - $w create line 116 16 110 10 -fill $outline -tags {floor1 bg} - $w create line 119 20 116 16 -fill $outline -tags {floor1 bg} - $w create line 122 28 119 20 -fill $outline -tags {floor1 bg} - $w create line 123 32 122 28 -fill $outline -tags {floor1 bg} - $w create line 123 68 123 32 -fill $outline -tags {floor1 bg} - $w create line 220 68 123 68 -fill $outline -tags {floor1 bg} - $w create line 386 129 386 104 -fill $outline -tags {floor1 bg} - $w create line 386 104 375 99 -fill $outline -tags {floor1 bg} - $w create line 375 99 363 92 -fill $outline -tags {floor1 bg} - $w create line 353 85 363 92 -fill $outline -tags {floor1 bg} - $w create line 220 68 220 34 -fill $outline -tags {floor1 bg} - $w create line 337 70 352 56 -fill $outline -tags {floor1 bg} - $w create line 352 56 358 48 -fill $outline -tags {floor1 bg} - $w create line 358 48 363 39 -fill $outline -tags {floor1 bg} - $w create line 363 39 365 29 -fill $outline -tags {floor1 bg} - $w create line 365 29 348 25 -fill $outline -tags {floor1 bg} - $w create line 348 25 335 22 -fill $outline -tags {floor1 bg} - $w create line 335 22 321 14 -fill $outline -tags {floor1 bg} - $w create line 321 14 300 5 -fill $outline -tags {floor1 bg} - $w create line 300 5 283 1 -fill $outline -tags {floor1 bg} - $w create line 283 1 260 0 -fill $outline -tags {floor1 bg} - $w create line 260 0 246 0 -fill $outline -tags {floor1 bg} - $w create line 246 0 242 2 -fill $outline -tags {floor1 bg} - $w create line 242 2 236 4 -fill $outline -tags {floor1 bg} - $w create line 236 4 231 8 -fill $outline -tags {floor1 bg} - $w create line 231 8 227 13 -fill $outline -tags {floor1 bg} - $w create line 223 17 227 13 -fill $outline -tags {floor1 bg} - $w create line 221 22 223 17 -fill $outline -tags {floor1 bg} - $w create line 220 34 221 22 -fill $outline -tags {floor1 bg} - $w create line 340 360 335 363 -fill $outline -tags {floor1 bg} - $w create line 335 363 331 365 -fill $outline -tags {floor1 bg} - $w create line 331 365 326 366 -fill $outline -tags {floor1 bg} - $w create line 326 366 304 366 -fill $outline -tags {floor1 bg} - $w create line 304 355 304 366 -fill $outline -tags {floor1 bg} - $w create line 395 288 400 288 -fill $outline -tags {floor1 bg} - $w create line 404 288 400 288 -fill $outline -tags {floor1 bg} - $w create line 409 290 404 288 -fill $outline -tags {floor1 bg} - $w create line 413 292 409 290 -fill $outline -tags {floor1 bg} - $w create line 418 297 413 292 -fill $outline -tags {floor1 bg} - $w create line 421 302 418 297 -fill $outline -tags {floor1 bg} - $w create line 422 309 421 302 -fill $outline -tags {floor1 bg} - $w create line 421 318 422 309 -fill $outline -tags {floor1 bg} - $w create line 421 318 417 325 -fill $outline -tags {floor1 bg} - $w create line 417 325 411 330 -fill $outline -tags {floor1 bg} - $w create line 411 330 405 332 -fill $outline -tags {floor1 bg} - $w create line 405 332 397 333 -fill $outline -tags {floor1 bg} - $w create line 397 333 344 333 -fill $outline -tags {floor1 bg} - $w create line 344 333 340 334 -fill $outline -tags {floor1 bg} - $w create line 340 334 336 336 -fill $outline -tags {floor1 bg} - $w create line 336 336 335 338 -fill $outline -tags {floor1 bg} - $w create line 335 338 332 342 -fill $outline -tags {floor1 bg} - $w create line 331 347 332 342 -fill $outline -tags {floor1 bg} - $w create line 332 351 331 347 -fill $outline -tags {floor1 bg} - $w create line 334 354 332 351 -fill $outline -tags {floor1 bg} - $w create line 336 357 334 354 -fill $outline -tags {floor1 bg} - $w create line 341 359 336 357 -fill $outline -tags {floor1 bg} - $w create line 341 359 340 360 -fill $outline -tags {floor1 bg} - $w create line 395 288 395 278 -fill $outline -tags {floor1 bg} - $w create line 304 355 258 355 -fill $outline -tags {floor1 bg} - $w create line 347 80 344 76 -fill $outline -tags {floor1 bg} - $w create line 344 76 337 70 -fill $outline -tags {floor1 bg} - $w create line 349 82 347 80 -fill $outline -tags {floor1 bg} - $w create line 351 84 349 82 -fill $outline -tags {floor1 bg} - $w create line 353 85 351 84 -fill $outline -tags {floor1 bg} -} - -# bg2 -- -# This procedure represents part of the floorplan database. When -# invoked, it instantiates the background information for the second -# floor. -# -# Arguments: -# w - The canvas window. -# fill - Fill color to use for the floor's background. -# outline - Color to use for the floor's outline. - -proc bg2 {w fill outline} { - $w create poly 559 129 484 129 484 162 398 162 398 129 315 129 \ - 315 133 176 133 176 129 96 129 96 133 3 133 3 339 0 339 0 391 \ - 60 391 60 387 258 387 258 329 350 329 350 311 395 311 395 280 \ - 484 280 484 311 508 311 508 327 558 327 558 391 644 391 644 \ - 367 802 367 802 129 725 129 725 133 559 133 559 129 \ - -tags {floor2 bg} -fill $fill - $w create line 350 311 350 329 -fill $outline -tags {floor2 bg} - $w create line 398 129 398 162 -fill $outline -tags {floor2 bg} - $w create line 802 367 802 129 -fill $outline -tags {floor2 bg} - $w create line 802 129 725 129 -fill $outline -tags {floor2 bg} - $w create line 725 133 725 129 -fill $outline -tags {floor2 bg} - $w create line 559 129 559 133 -fill $outline -tags {floor2 bg} - $w create line 559 133 725 133 -fill $outline -tags {floor2 bg} - $w create line 484 162 484 129 -fill $outline -tags {floor2 bg} - $w create line 559 129 484 129 -fill $outline -tags {floor2 bg} - $w create line 802 367 644 367 -fill $outline -tags {floor2 bg} - $w create line 644 367 644 391 -fill $outline -tags {floor2 bg} - $w create line 644 391 558 391 -fill $outline -tags {floor2 bg} - $w create line 558 327 558 391 -fill $outline -tags {floor2 bg} - $w create line 558 327 508 327 -fill $outline -tags {floor2 bg} - $w create line 508 327 508 311 -fill $outline -tags {floor2 bg} - $w create line 484 311 508 311 -fill $outline -tags {floor2 bg} - $w create line 484 280 484 311 -fill $outline -tags {floor2 bg} - $w create line 398 162 484 162 -fill $outline -tags {floor2 bg} - $w create line 484 280 395 280 -fill $outline -tags {floor2 bg} - $w create line 395 280 395 311 -fill $outline -tags {floor2 bg} - $w create line 258 387 60 387 -fill $outline -tags {floor2 bg} - $w create line 3 133 3 339 -fill $outline -tags {floor2 bg} - $w create line 3 339 0 339 -fill $outline -tags {floor2 bg} - $w create line 60 391 0 391 -fill $outline -tags {floor2 bg} - $w create line 0 339 0 391 -fill $outline -tags {floor2 bg} - $w create line 60 387 60 391 -fill $outline -tags {floor2 bg} - $w create line 258 329 258 387 -fill $outline -tags {floor2 bg} - $w create line 350 329 258 329 -fill $outline -tags {floor2 bg} - $w create line 395 311 350 311 -fill $outline -tags {floor2 bg} - $w create line 398 129 315 129 -fill $outline -tags {floor2 bg} - $w create line 176 133 315 133 -fill $outline -tags {floor2 bg} - $w create line 176 129 96 129 -fill $outline -tags {floor2 bg} - $w create line 3 133 96 133 -fill $outline -tags {floor2 bg} - $w create line 315 133 315 129 -fill $outline -tags {floor2 bg} - $w create line 176 133 176 129 -fill $outline -tags {floor2 bg} - $w create line 96 133 96 129 -fill $outline -tags {floor2 bg} -} - -# bg3 -- -# This procedure represents part of the floorplan database. When -# invoked, it instantiates the background information for the third -# floor. -# -# Arguments: -# w - The canvas window. -# fill - Fill color to use for the floor's background. -# outline - Color to use for the floor's outline. - -proc bg3 {w fill outline} { - $w create poly 159 300 107 300 107 248 159 248 159 129 96 129 96 \ - 133 21 133 21 331 0 331 0 391 60 391 60 370 159 370 159 300 \ - -tags {floor3 bg} -fill $fill - $w create poly 258 370 258 329 350 329 350 311 399 311 399 129 \ - 315 129 315 133 176 133 176 129 159 129 159 370 258 370 \ - -tags {floor3 bg} -fill $fill - $w create line 96 133 96 129 -fill $outline -tags {floor3 bg} - $w create line 176 129 96 129 -fill $outline -tags {floor3 bg} - $w create line 176 129 176 133 -fill $outline -tags {floor3 bg} - $w create line 315 133 176 133 -fill $outline -tags {floor3 bg} - $w create line 315 133 315 129 -fill $outline -tags {floor3 bg} - $w create line 399 129 315 129 -fill $outline -tags {floor3 bg} - $w create line 399 311 399 129 -fill $outline -tags {floor3 bg} - $w create line 399 311 350 311 -fill $outline -tags {floor3 bg} - $w create line 350 329 350 311 -fill $outline -tags {floor3 bg} - $w create line 350 329 258 329 -fill $outline -tags {floor3 bg} - $w create line 258 370 258 329 -fill $outline -tags {floor3 bg} - $w create line 60 370 258 370 -fill $outline -tags {floor3 bg} - $w create line 60 370 60 391 -fill $outline -tags {floor3 bg} - $w create line 60 391 0 391 -fill $outline -tags {floor3 bg} - $w create line 0 391 0 331 -fill $outline -tags {floor3 bg} - $w create line 21 331 0 331 -fill $outline -tags {floor3 bg} - $w create line 21 331 21 133 -fill $outline -tags {floor3 bg} - $w create line 96 133 21 133 -fill $outline -tags {floor3 bg} - $w create line 107 300 159 300 159 248 107 248 107 300 \ - -fill $outline -tags {floor3 bg} -} - -# fg1 -- -# This procedure represents part of the floorplan database. When -# invoked, it instantiates the foreground information for the first -# floor (office outlines and numbers). -# -# Arguments: -# w - The canvas window. -# color - Color to use for drawing foreground information. - -proc fg1 {w color} { - global floorLabels floorItems - set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor1 room}] - set floorLabels($i) 101 - set {floorItems(101)} $i - $w create text 358 209 -text 101 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -tags {floor1 room}] - set floorLabels($i) {Pub Lift1} - set {floorItems(Pub Lift1)} $i - $w create text 323 223 -text {Pub Lift1} -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -tags {floor1 room}] - set floorLabels($i) {Priv Lift1} - set {floorItems(Priv Lift1)} $i - $w create text 323 188 -text {Priv Lift1} -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 42 389 42 337 1 337 1 389 -fill {} -tags {floor1 room}] - set floorLabels($i) 110 - set {floorItems(110)} $i - $w create text 21.5 363 -text 110 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 59 389 59 385 90 385 90 337 44 337 44 389 -fill {} -tags {floor1 room}] - set floorLabels($i) 109 - set {floorItems(109)} $i - $w create text 67 363 -text 109 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 51 300 51 253 6 253 6 300 -fill {} -tags {floor1 room}] - set floorLabels($i) 111 - set {floorItems(111)} $i - $w create text 28.5 276.5 -text 111 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 98 248 98 309 79 309 79 248 -fill {} -tags {floor1 room}] - set floorLabels($i) 117B - set {floorItems(117B)} $i - $w create text 88.5 278.5 -text 117B -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 51 251 51 204 6 204 6 251 -fill {} -tags {floor1 room}] - set floorLabels($i) 112 - set {floorItems(112)} $i - $w create text 28.5 227.5 -text 112 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 6 156 51 156 51 203 6 203 -fill {} -tags {floor1 room}] - set floorLabels($i) 113 - set {floorItems(113)} $i - $w create text 28.5 179.5 -text 113 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 85 169 79 169 79 192 85 192 -fill {} -tags {floor1 room}] - set floorLabels($i) 117A - set {floorItems(117A)} $i - $w create text 82 180.5 -text 117A -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 77 302 77 168 53 168 53 302 -fill {} -tags {floor1 room}] - set floorLabels($i) 117 - set {floorItems(117)} $i - $w create text 65 235 -text 117 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 51 155 51 115 6 115 6 155 -fill {} -tags {floor1 room}] - set floorLabels($i) 114 - set {floorItems(114)} $i - $w create text 28.5 135 -text 114 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 95 115 53 115 53 168 95 168 -fill {} -tags {floor1 room}] - set floorLabels($i) 115 - set {floorItems(115)} $i - $w create text 74 141.5 -text 115 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 87 113 87 27 10 27 10 113 -fill {} -tags {floor1 room}] - set floorLabels($i) 116 - set {floorItems(116)} $i - $w create text 48.5 70 -text 116 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 89 91 128 91 128 113 89 113 -fill {} -tags {floor1 room}] - set floorLabels($i) 118 - set {floorItems(118)} $i - $w create text 108.5 102 -text 118 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 178 128 178 132 216 132 216 91 163 91 163 112 149 112 149 128 -fill {} -tags {floor1 room}] - set floorLabels($i) 120 - set {floorItems(120)} $i - $w create text 189.5 111.5 -text 120 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 79 193 87 193 87 169 136 169 136 192 156 192 156 169 175 169 175 246 79 246 -fill {} -tags {floor1 room}] - set floorLabels($i) 122 - set {floorItems(122)} $i - $w create text 131 207.5 -text 122 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 138 169 154 169 154 191 138 191 -fill {} -tags {floor1 room}] - set floorLabels($i) 121 - set {floorItems(121)} $i - $w create text 146 180 -text 121 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 99 300 126 300 126 309 99 309 -fill {} -tags {floor1 room}] - set floorLabels($i) 106A - set {floorItems(106A)} $i - $w create text 112.5 304.5 -text 106A -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 128 299 128 309 150 309 150 248 99 248 99 299 -fill {} -tags {floor1 room}] - set floorLabels($i) 105 - set {floorItems(105)} $i - $w create text 124.5 278.5 -text 105 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 174 309 174 300 152 300 152 309 -fill {} -tags {floor1 room}] - set floorLabels($i) 106B - set {floorItems(106B)} $i - $w create text 163 304.5 -text 106B -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 176 299 176 309 216 309 216 248 152 248 152 299 -fill {} -tags {floor1 room}] - set floorLabels($i) 104 - set {floorItems(104)} $i - $w create text 184 278.5 -text 104 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 138 385 138 337 91 337 91 385 -fill {} -tags {floor1 room}] - set floorLabels($i) 108 - set {floorItems(108)} $i - $w create text 114.5 361 -text 108 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 256 337 140 337 140 385 256 385 -fill {} -tags {floor1 room}] - set floorLabels($i) 107 - set {floorItems(107)} $i - $w create text 198 361 -text 107 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 300 353 300 329 260 329 260 353 -fill {} -tags {floor1 room}] - set floorLabels($i) Smoking - set {floorItems(Smoking)} $i - $w create text 280 341 -text Smoking -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 314 135 314 170 306 170 306 246 177 246 177 135 -fill {} -tags {floor1 room}] - set floorLabels($i) 123 - set {floorItems(123)} $i - $w create text 245.5 190.5 -text 123 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 217 248 301 248 301 326 257 326 257 310 217 310 -fill {} -tags {floor1 room}] - set floorLabels($i) 103 - set {floorItems(103)} $i - $w create text 259 287 -text 103 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 396 188 377 188 377 169 316 169 316 131 396 131 -fill {} -tags {floor1 room}] - set floorLabels($i) 124 - set {floorItems(124)} $i - $w create text 356 150 -text 124 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 397 226 407 226 407 189 377 189 377 246 397 246 -fill {} -tags {floor1 room}] - set floorLabels($i) 125 - set {floorItems(125)} $i - $w create text 392 217.5 -text 125 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 399 187 409 187 409 207 474 207 474 164 399 164 -fill {} -tags {floor1 room}] - set floorLabels($i) 126 - set {floorItems(126)} $i - $w create text 436.5 185.5 -text 126 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 409 209 409 229 399 229 399 253 486 253 486 239 474 239 474 209 -fill {} -tags {floor1 room}] - set floorLabels($i) 127 - set {floorItems(127)} $i - $w create text 436.5 231 -text 127 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 501 164 501 174 495 174 495 188 490 188 490 204 476 204 476 164 -fill {} -tags {floor1 room}] - set floorLabels($i) MShower - set {floorItems(MShower)} $i - $w create text 488.5 184 -text MShower -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 497 176 513 176 513 204 492 204 492 190 497 190 -fill {} -tags {floor1 room}] - set floorLabels($i) Closet - set {floorItems(Closet)} $i - $w create text 502.5 190 -text Closet -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 476 237 476 206 513 206 513 254 488 254 488 237 -fill {} -tags {floor1 room}] - set floorLabels($i) WShower - set {floorItems(WShower)} $i - $w create text 494.5 230 -text WShower -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 486 131 558 131 558 135 724 135 724 166 697 166 697 275 553 275 531 254 515 254 515 174 503 174 503 161 486 161 -fill {} -tags {floor1 room}] - set floorLabels($i) 130 - set {floorItems(130)} $i - $w create text 638.5 205 -text 130 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 308 242 339 242 339 248 342 248 342 246 397 246 397 276 393 276 393 309 300 309 300 248 308 248 -fill {} -tags {floor1 room}] - set floorLabels($i) 102 - set {floorItems(102)} $i - $w create text 367.5 278.5 -text 102 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 397 255 486 255 486 276 397 276 -fill {} -tags {floor1 room}] - set floorLabels($i) 128 - set {floorItems(128)} $i - $w create text 441.5 265.5 -text 128 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 510 309 486 309 486 255 530 255 552 277 561 277 561 325 510 325 -fill {} -tags {floor1 room}] - set floorLabels($i) 129 - set {floorItems(129)} $i - $w create text 535.5 293 -text 129 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 696 281 740 281 740 387 642 387 642 389 561 389 561 277 696 277 -fill {} -tags {floor1 room}] - set floorLabels($i) 133 - set {floorItems(133)} $i - $w create text 628.5 335 -text 133 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 742 387 742 281 800 281 800 387 -fill {} -tags {floor1 room}] - set floorLabels($i) 132 - set {floorItems(132)} $i - $w create text 771 334 -text 132 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 800 168 800 280 699 280 699 168 -fill {} -tags {floor1 room}] - set floorLabels($i) 134 - set {floorItems(134)} $i - $w create text 749.5 224 -text 134 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 726 131 726 166 800 166 800 131 -fill {} -tags {floor1 room}] - set floorLabels($i) 135 - set {floorItems(135)} $i - $w create text 763 148.5 -text 135 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 340 360 335 363 331 365 326 366 304 366 304 312 396 312 396 288 400 288 404 288 409 290 413 292 418 297 421 302 422 309 421 318 417 325 411 330 405 332 397 333 344 333 340 334 336 336 335 338 332 342 331 347 332 351 334 354 336 357 341 359 -fill {} -tags {floor1 room}] - set floorLabels($i) {Ramona Stair} - set {floorItems(Ramona Stair)} $i - $w create text 368 323 -text {Ramona Stair} -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 30 23 30 5 93 5 98 5 104 7 110 10 116 16 119 20 122 28 123 32 123 68 220 68 220 87 90 87 90 23 -fill {} -tags {floor1 room}] - set floorLabels($i) {University Stair} - set {floorItems(University Stair)} $i - $w create text 155 77.5 -text {University Stair} -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 282 37 295 40 312 49 323 56 337 70 352 56 358 48 363 39 365 29 348 25 335 22 321 14 300 5 283 1 260 0 246 0 242 2 236 4 231 8 227 13 223 17 221 22 220 34 260 34 -fill {} -tags {floor1 room}] - set floorLabels($i) {Plaza Stair} - set {floorItems(Plaza Stair)} $i - $w create text 317.5 28.5 -text {Plaza Stair} -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 220 34 260 34 282 37 295 40 312 49 323 56 337 70 350 83 365 94 377 100 386 104 386 128 220 128 -fill {} -tags {floor1 room}] - set floorLabels($i) {Plaza Deck} - set {floorItems(Plaza Deck)} $i - $w create text 303 81 -text {Plaza Deck} -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 257 336 77 336 6 336 6 301 77 301 77 310 257 310 -fill {} -tags {floor1 room}] - set floorLabels($i) 106 - set {floorItems(106)} $i - $w create text 131.5 318.5 -text 106 -fill $color -anchor c -tags {floor1 label} - set i [$w create polygon 146 110 162 110 162 91 130 91 130 115 95 115 95 128 114 128 114 151 157 151 157 153 112 153 112 130 97 130 97 168 175 168 175 131 146 131 -fill {} -tags {floor1 room}] - set floorLabels($i) 119 - set {floorItems(119)} $i - $w create text 143.5 133 -text 119 -fill $color -anchor c -tags {floor1 label} - $w create line 155 191 155 189 -fill $color -tags {floor1 wall} - $w create line 155 177 155 169 -fill $color -tags {floor1 wall} - $w create line 96 129 96 169 -fill $color -tags {floor1 wall} - $w create line 78 169 176 169 -fill $color -tags {floor1 wall} - $w create line 176 247 176 129 -fill $color -tags {floor1 wall} - $w create line 340 206 307 206 -fill $color -tags {floor1 wall} - $w create line 340 187 340 170 -fill $color -tags {floor1 wall} - $w create line 340 210 340 201 -fill $color -tags {floor1 wall} - $w create line 340 247 340 224 -fill $color -tags {floor1 wall} - $w create line 340 241 307 241 -fill $color -tags {floor1 wall} - $w create line 376 246 376 170 -fill $color -tags {floor1 wall} - $w create line 307 247 307 170 -fill $color -tags {floor1 wall} - $w create line 376 170 307 170 -fill $color -tags {floor1 wall} - $w create line 315 129 315 170 -fill $color -tags {floor1 wall} - $w create line 147 129 176 129 -fill $color -tags {floor1 wall} - $w create line 202 133 176 133 -fill $color -tags {floor1 wall} - $w create line 398 129 315 129 -fill $color -tags {floor1 wall} - $w create line 258 352 258 387 -fill $color -tags {floor1 wall} - $w create line 60 387 60 391 -fill $color -tags {floor1 wall} - $w create line 0 337 0 391 -fill $color -tags {floor1 wall} - $w create line 60 391 0 391 -fill $color -tags {floor1 wall} - $w create line 3 114 3 337 -fill $color -tags {floor1 wall} - $w create line 258 387 60 387 -fill $color -tags {floor1 wall} - $w create line 52 237 52 273 -fill $color -tags {floor1 wall} - $w create line 52 189 52 225 -fill $color -tags {floor1 wall} - $w create line 52 140 52 177 -fill $color -tags {floor1 wall} - $w create line 395 306 395 311 -fill $color -tags {floor1 wall} - $w create line 531 254 398 254 -fill $color -tags {floor1 wall} - $w create line 475 178 475 238 -fill $color -tags {floor1 wall} - $w create line 502 162 398 162 -fill $color -tags {floor1 wall} - $w create line 398 129 398 188 -fill $color -tags {floor1 wall} - $w create line 383 188 376 188 -fill $color -tags {floor1 wall} - $w create line 408 188 408 194 -fill $color -tags {floor1 wall} - $w create line 398 227 398 254 -fill $color -tags {floor1 wall} - $w create line 408 227 398 227 -fill $color -tags {floor1 wall} - $w create line 408 222 408 227 -fill $color -tags {floor1 wall} - $w create line 408 206 408 210 -fill $color -tags {floor1 wall} - $w create line 408 208 475 208 -fill $color -tags {floor1 wall} - $w create line 484 278 484 311 -fill $color -tags {floor1 wall} - $w create line 484 311 508 311 -fill $color -tags {floor1 wall} - $w create line 508 327 508 311 -fill $color -tags {floor1 wall} - $w create line 559 327 508 327 -fill $color -tags {floor1 wall} - $w create line 644 391 559 391 -fill $color -tags {floor1 wall} - $w create line 644 389 644 391 -fill $color -tags {floor1 wall} - $w create line 514 205 475 205 -fill $color -tags {floor1 wall} - $w create line 496 189 496 187 -fill $color -tags {floor1 wall} - $w create line 559 129 484 129 -fill $color -tags {floor1 wall} - $w create line 484 162 484 129 -fill $color -tags {floor1 wall} - $w create line 725 133 559 133 -fill $color -tags {floor1 wall} - $w create line 559 129 559 133 -fill $color -tags {floor1 wall} - $w create line 725 149 725 167 -fill $color -tags {floor1 wall} - $w create line 725 129 802 129 -fill $color -tags {floor1 wall} - $w create line 802 389 802 129 -fill $color -tags {floor1 wall} - $w create line 739 167 802 167 -fill $color -tags {floor1 wall} - $w create line 396 188 408 188 -fill $color -tags {floor1 wall} - $w create line 0 337 9 337 -fill $color -tags {floor1 wall} - $w create line 58 337 21 337 -fill $color -tags {floor1 wall} - $w create line 43 391 43 337 -fill $color -tags {floor1 wall} - $w create line 105 337 75 337 -fill $color -tags {floor1 wall} - $w create line 91 387 91 337 -fill $color -tags {floor1 wall} - $w create line 154 337 117 337 -fill $color -tags {floor1 wall} - $w create line 139 387 139 337 -fill $color -tags {floor1 wall} - $w create line 227 337 166 337 -fill $color -tags {floor1 wall} - $w create line 258 337 251 337 -fill $color -tags {floor1 wall} - $w create line 258 328 302 328 -fill $color -tags {floor1 wall} - $w create line 302 355 302 311 -fill $color -tags {floor1 wall} - $w create line 395 311 302 311 -fill $color -tags {floor1 wall} - $w create line 484 278 395 278 -fill $color -tags {floor1 wall} - $w create line 395 294 395 278 -fill $color -tags {floor1 wall} - $w create line 473 278 473 275 -fill $color -tags {floor1 wall} - $w create line 473 256 473 254 -fill $color -tags {floor1 wall} - $w create line 533 257 531 254 -fill $color -tags {floor1 wall} - $w create line 553 276 551 274 -fill $color -tags {floor1 wall} - $w create line 698 276 553 276 -fill $color -tags {floor1 wall} - $w create line 559 391 559 327 -fill $color -tags {floor1 wall} - $w create line 802 389 644 389 -fill $color -tags {floor1 wall} - $w create line 741 314 741 389 -fill $color -tags {floor1 wall} - $w create line 698 280 698 167 -fill $color -tags {floor1 wall} - $w create line 707 280 698 280 -fill $color -tags {floor1 wall} - $w create line 802 280 731 280 -fill $color -tags {floor1 wall} - $w create line 741 280 741 302 -fill $color -tags {floor1 wall} - $w create line 698 167 727 167 -fill $color -tags {floor1 wall} - $w create line 725 137 725 129 -fill $color -tags {floor1 wall} - $w create line 514 254 514 175 -fill $color -tags {floor1 wall} - $w create line 496 175 514 175 -fill $color -tags {floor1 wall} - $w create line 502 175 502 162 -fill $color -tags {floor1 wall} - $w create line 475 166 475 162 -fill $color -tags {floor1 wall} - $w create line 496 176 496 175 -fill $color -tags {floor1 wall} - $w create line 491 189 496 189 -fill $color -tags {floor1 wall} - $w create line 491 205 491 189 -fill $color -tags {floor1 wall} - $w create line 487 238 475 238 -fill $color -tags {floor1 wall} - $w create line 487 240 487 238 -fill $color -tags {floor1 wall} - $w create line 487 252 487 254 -fill $color -tags {floor1 wall} - $w create line 315 133 304 133 -fill $color -tags {floor1 wall} - $w create line 256 133 280 133 -fill $color -tags {floor1 wall} - $w create line 78 247 270 247 -fill $color -tags {floor1 wall} - $w create line 307 247 294 247 -fill $color -tags {floor1 wall} - $w create line 214 133 232 133 -fill $color -tags {floor1 wall} - $w create line 217 247 217 266 -fill $color -tags {floor1 wall} - $w create line 217 309 217 291 -fill $color -tags {floor1 wall} - $w create line 217 309 172 309 -fill $color -tags {floor1 wall} - $w create line 154 309 148 309 -fill $color -tags {floor1 wall} - $w create line 175 300 175 309 -fill $color -tags {floor1 wall} - $w create line 151 300 175 300 -fill $color -tags {floor1 wall} - $w create line 151 247 151 309 -fill $color -tags {floor1 wall} - $w create line 78 237 78 265 -fill $color -tags {floor1 wall} - $w create line 78 286 78 309 -fill $color -tags {floor1 wall} - $w create line 106 309 78 309 -fill $color -tags {floor1 wall} - $w create line 130 309 125 309 -fill $color -tags {floor1 wall} - $w create line 99 309 99 247 -fill $color -tags {floor1 wall} - $w create line 127 299 99 299 -fill $color -tags {floor1 wall} - $w create line 127 309 127 299 -fill $color -tags {floor1 wall} - $w create line 155 191 137 191 -fill $color -tags {floor1 wall} - $w create line 137 169 137 191 -fill $color -tags {floor1 wall} - $w create line 78 171 78 169 -fill $color -tags {floor1 wall} - $w create line 78 190 78 218 -fill $color -tags {floor1 wall} - $w create line 86 192 86 169 -fill $color -tags {floor1 wall} - $w create line 86 192 78 192 -fill $color -tags {floor1 wall} - $w create line 52 301 3 301 -fill $color -tags {floor1 wall} - $w create line 52 286 52 301 -fill $color -tags {floor1 wall} - $w create line 52 252 3 252 -fill $color -tags {floor1 wall} - $w create line 52 203 3 203 -fill $color -tags {floor1 wall} - $w create line 3 156 52 156 -fill $color -tags {floor1 wall} - $w create line 8 25 8 114 -fill $color -tags {floor1 wall} - $w create line 63 114 3 114 -fill $color -tags {floor1 wall} - $w create line 75 114 97 114 -fill $color -tags {floor1 wall} - $w create line 108 114 129 114 -fill $color -tags {floor1 wall} - $w create line 129 114 129 89 -fill $color -tags {floor1 wall} - $w create line 52 114 52 128 -fill $color -tags {floor1 wall} - $w create line 132 89 88 89 -fill $color -tags {floor1 wall} - $w create line 88 25 88 89 -fill $color -tags {floor1 wall} - $w create line 88 114 88 89 -fill $color -tags {floor1 wall} - $w create line 218 89 144 89 -fill $color -tags {floor1 wall} - $w create line 147 111 147 129 -fill $color -tags {floor1 wall} - $w create line 162 111 147 111 -fill $color -tags {floor1 wall} - $w create line 162 109 162 111 -fill $color -tags {floor1 wall} - $w create line 162 96 162 89 -fill $color -tags {floor1 wall} - $w create line 218 89 218 94 -fill $color -tags {floor1 wall} - $w create line 218 89 218 119 -fill $color -tags {floor1 wall} - $w create line 8 25 88 25 -fill $color -tags {floor1 wall} - $w create line 258 337 258 328 -fill $color -tags {floor1 wall} - $w create line 113 129 96 129 -fill $color -tags {floor1 wall} - $w create line 302 355 258 355 -fill $color -tags {floor1 wall} - $w create line 386 104 386 129 -fill $color -tags {floor1 wall} - $w create line 377 100 386 104 -fill $color -tags {floor1 wall} - $w create line 365 94 377 100 -fill $color -tags {floor1 wall} - $w create line 350 83 365 94 -fill $color -tags {floor1 wall} - $w create line 337 70 350 83 -fill $color -tags {floor1 wall} - $w create line 337 70 323 56 -fill $color -tags {floor1 wall} - $w create line 312 49 323 56 -fill $color -tags {floor1 wall} - $w create line 295 40 312 49 -fill $color -tags {floor1 wall} - $w create line 282 37 295 40 -fill $color -tags {floor1 wall} - $w create line 260 34 282 37 -fill $color -tags {floor1 wall} - $w create line 253 34 260 34 -fill $color -tags {floor1 wall} - $w create line 386 128 386 104 -fill $color -tags {floor1 wall} - $w create line 113 152 156 152 -fill $color -tags {floor1 wall} - $w create line 113 152 156 152 -fill $color -tags {floor1 wall} - $w create line 113 152 113 129 -fill $color -tags {floor1 wall} -} - -# fg2 -- -# This procedure represents part of the floorplan database. When -# invoked, it instantiates the foreground information for the second -# floor (office outlines and numbers). -# -# Arguments: -# w - The canvas window. -# color - Color to use for drawing foreground information. - -proc fg2 {w color} { - global floorLabels floorItems - set i [$w create polygon 748 188 755 188 755 205 758 205 758 222 800 222 800 168 748 168 -fill {} -tags {floor2 room}] - set floorLabels($i) 238 - set {floorItems(238)} $i - $w create text 774 195 -text 238 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 726 188 746 188 746 166 800 166 800 131 726 131 -fill {} -tags {floor2 room}] - set floorLabels($i) 237 - set {floorItems(237)} $i - $w create text 763 148.5 -text 237 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 497 187 497 204 559 204 559 324 641 324 643 324 643 291 641 291 641 205 696 205 696 291 694 291 694 314 715 314 715 291 715 205 755 205 755 190 724 190 724 187 -fill {} -tags {floor2 room}] - set floorLabels($i) 246 - set {floorItems(246)} $i - $w create text 600 264 -text 246 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 694 279 643 279 643 314 694 314 -fill {} -tags {floor2 room}] - set floorLabels($i) 247 - set {floorItems(247)} $i - $w create text 668.5 296.5 -text 247 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 232 250 308 250 308 242 339 242 339 246 397 246 397 255 476 255 476 250 482 250 559 250 559 274 482 274 482 278 396 278 396 274 232 274 -fill {} -tags {floor2 room}] - set floorLabels($i) 202 - set {floorItems(202)} $i - $w create text 285.5 260 -text 202 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 53 228 53 338 176 338 233 338 233 196 306 196 306 180 175 180 175 169 156 169 156 196 176 196 176 228 -fill {} -tags {floor2 room}] - set floorLabels($i) 206 - set {floorItems(206)} $i - $w create text 143 267 -text 206 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 51 277 6 277 6 338 51 338 -fill {} -tags {floor2 room}] - set floorLabels($i) 212 - set {floorItems(212)} $i - $w create text 28.5 307.5 -text 212 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 557 276 486 276 486 309 510 309 510 325 557 325 -fill {} -tags {floor2 room}] - set floorLabels($i) 245 - set {floorItems(245)} $i - $w create text 521.5 300.5 -text 245 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 560 389 599 389 599 326 560 326 -fill {} -tags {floor2 room}] - set floorLabels($i) 244 - set {floorItems(244)} $i - $w create text 579.5 357.5 -text 244 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 601 389 601 326 643 326 643 389 -fill {} -tags {floor2 room}] - set floorLabels($i) 243 - set {floorItems(243)} $i - $w create text 622 357.5 -text 243 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 688 316 645 316 645 365 688 365 -fill {} -tags {floor2 room}] - set floorLabels($i) 242 - set {floorItems(242)} $i - $w create text 666.5 340.5 -text 242 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 802 367 759 367 759 226 802 226 -fill {} -tags {floor2 room}] - set floorLabels($i) {Barbecue Deck} - set {floorItems(Barbecue Deck)} $i - $w create text 780.5 296.5 -text {Barbecue Deck} -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 755 262 755 314 717 314 717 262 -fill {} -tags {floor2 room}] - set floorLabels($i) 240 - set {floorItems(240)} $i - $w create text 736 288 -text 240 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 755 316 689 316 689 365 755 365 -fill {} -tags {floor2 room}] - set floorLabels($i) 241 - set {floorItems(241)} $i - $w create text 722 340.5 -text 241 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 755 206 717 206 717 261 755 261 -fill {} -tags {floor2 room}] - set floorLabels($i) 239 - set {floorItems(239)} $i - $w create text 736 233.5 -text 239 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 695 277 643 277 643 206 695 206 -fill {} -tags {floor2 room}] - set floorLabels($i) 248 - set {floorItems(248)} $i - $w create text 669 241.5 -text 248 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 676 135 676 185 724 185 724 135 -fill {} -tags {floor2 room}] - set floorLabels($i) 236 - set {floorItems(236)} $i - $w create text 700 160 -text 236 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 675 135 635 135 635 145 628 145 628 185 675 185 -fill {} -tags {floor2 room}] - set floorLabels($i) 235 - set {floorItems(235)} $i - $w create text 651.5 160 -text 235 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 626 143 633 143 633 135 572 135 572 143 579 143 579 185 626 185 -fill {} -tags {floor2 room}] - set floorLabels($i) 234 - set {floorItems(234)} $i - $w create text 606 160 -text 234 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 557 135 571 135 571 145 578 145 578 185 527 185 527 131 557 131 -fill {} -tags {floor2 room}] - set floorLabels($i) 233 - set {floorItems(233)} $i - $w create text 552.5 158 -text 233 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 476 249 557 249 557 205 476 205 -fill {} -tags {floor2 room}] - set floorLabels($i) 230 - set {floorItems(230)} $i - $w create text 516.5 227 -text 230 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 476 164 486 164 486 131 525 131 525 185 476 185 -fill {} -tags {floor2 room}] - set floorLabels($i) 232 - set {floorItems(232)} $i - $w create text 500.5 158 -text 232 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 476 186 495 186 495 204 476 204 -fill {} -tags {floor2 room}] - set floorLabels($i) 229 - set {floorItems(229)} $i - $w create text 485.5 195 -text 229 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 474 207 409 207 409 187 399 187 399 164 474 164 -fill {} -tags {floor2 room}] - set floorLabels($i) 227 - set {floorItems(227)} $i - $w create text 436.5 185.5 -text 227 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 399 228 399 253 474 253 474 209 409 209 409 228 -fill {} -tags {floor2 room}] - set floorLabels($i) 228 - set {floorItems(228)} $i - $w create text 436.5 231 -text 228 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 397 246 397 226 407 226 407 189 377 189 377 246 -fill {} -tags {floor2 room}] - set floorLabels($i) 226 - set {floorItems(226)} $i - $w create text 392 217.5 -text 226 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 377 169 316 169 316 131 397 131 397 188 377 188 -fill {} -tags {floor2 room}] - set floorLabels($i) 225 - set {floorItems(225)} $i - $w create text 356.5 150 -text 225 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 234 198 306 198 306 249 234 249 -fill {} -tags {floor2 room}] - set floorLabels($i) 224 - set {floorItems(224)} $i - $w create text 270 223.5 -text 224 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 270 179 306 179 306 170 314 170 314 135 270 135 -fill {} -tags {floor2 room}] - set floorLabels($i) 223 - set {floorItems(223)} $i - $w create text 292 157 -text 223 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 268 179 221 179 221 135 268 135 -fill {} -tags {floor2 room}] - set floorLabels($i) 222 - set {floorItems(222)} $i - $w create text 244.5 157 -text 222 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 177 179 219 179 219 135 177 135 -fill {} -tags {floor2 room}] - set floorLabels($i) 221 - set {floorItems(221)} $i - $w create text 198 157 -text 221 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 299 327 349 327 349 284 341 284 341 276 299 276 -fill {} -tags {floor2 room}] - set floorLabels($i) 204 - set {floorItems(204)} $i - $w create text 324 301.5 -text 204 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 234 276 297 276 297 327 257 327 257 338 234 338 -fill {} -tags {floor2 room}] - set floorLabels($i) 205 - set {floorItems(205)} $i - $w create text 265.5 307 -text 205 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 256 385 256 340 212 340 212 385 -fill {} -tags {floor2 room}] - set floorLabels($i) 207 - set {floorItems(207)} $i - $w create text 234 362.5 -text 207 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 210 340 164 340 164 385 210 385 -fill {} -tags {floor2 room}] - set floorLabels($i) 208 - set {floorItems(208)} $i - $w create text 187 362.5 -text 208 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 115 340 162 340 162 385 115 385 -fill {} -tags {floor2 room}] - set floorLabels($i) 209 - set {floorItems(209)} $i - $w create text 138.5 362.5 -text 209 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 89 228 89 156 53 156 53 228 -fill {} -tags {floor2 room}] - set floorLabels($i) 217 - set {floorItems(217)} $i - $w create text 71 192 -text 217 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 89 169 97 169 97 190 89 190 -fill {} -tags {floor2 room}] - set floorLabels($i) 217A - set {floorItems(217A)} $i - $w create text 93 179.5 -text 217A -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 89 156 89 168 95 168 95 135 53 135 53 156 -fill {} -tags {floor2 room}] - set floorLabels($i) 216 - set {floorItems(216)} $i - $w create text 71 145.5 -text 216 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 51 179 51 135 6 135 6 179 -fill {} -tags {floor2 room}] - set floorLabels($i) 215 - set {floorItems(215)} $i - $w create text 28.5 157 -text 215 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 51 227 6 227 6 180 51 180 -fill {} -tags {floor2 room}] - set floorLabels($i) 214 - set {floorItems(214)} $i - $w create text 28.5 203.5 -text 214 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 51 275 6 275 6 229 51 229 -fill {} -tags {floor2 room}] - set floorLabels($i) 213 - set {floorItems(213)} $i - $w create text 28.5 252 -text 213 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 114 340 67 340 67 385 114 385 -fill {} -tags {floor2 room}] - set floorLabels($i) 210 - set {floorItems(210)} $i - $w create text 90.5 362.5 -text 210 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 59 389 59 385 65 385 65 340 1 340 1 389 -fill {} -tags {floor2 room}] - set floorLabels($i) 211 - set {floorItems(211)} $i - $w create text 33 364.5 -text 211 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 393 309 350 309 350 282 342 282 342 276 393 276 -fill {} -tags {floor2 room}] - set floorLabels($i) 203 - set {floorItems(203)} $i - $w create text 367.5 292.5 -text 203 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 99 191 91 191 91 226 174 226 174 198 154 198 154 192 109 192 109 169 99 169 -fill {} -tags {floor2 room}] - set floorLabels($i) 220 - set {floorItems(220)} $i - $w create text 132.5 208.5 -text 220 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -tags {floor2 room}] - set floorLabels($i) {Priv Lift2} - set {floorItems(Priv Lift2)} $i - $w create text 323 188 -text {Priv Lift2} -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -tags {floor2 room}] - set floorLabels($i) {Pub Lift 2} - set {floorItems(Pub Lift 2)} $i - $w create text 323 223 -text {Pub Lift 2} -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 175 168 97 168 97 131 175 131 -fill {} -tags {floor2 room}] - set floorLabels($i) 218 - set {floorItems(218)} $i - $w create text 136 149.5 -text 218 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 154 191 111 191 111 169 154 169 -fill {} -tags {floor2 room}] - set floorLabels($i) 219 - set {floorItems(219)} $i - $w create text 132.5 180 -text 219 -fill $color -anchor c -tags {floor2 label} - set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor2 room}] - set floorLabels($i) 201 - set {floorItems(201)} $i - $w create text 358 209 -text 201 -fill $color -anchor c -tags {floor2 label} - $w create line 641 186 678 186 -fill $color -tags {floor2 wall} - $w create line 757 350 757 367 -fill $color -tags {floor2 wall} - $w create line 634 133 634 144 -fill $color -tags {floor2 wall} - $w create line 634 144 627 144 -fill $color -tags {floor2 wall} - $w create line 572 133 572 144 -fill $color -tags {floor2 wall} - $w create line 572 144 579 144 -fill $color -tags {floor2 wall} - $w create line 398 129 398 162 -fill $color -tags {floor2 wall} - $w create line 174 197 175 197 -fill $color -tags {floor2 wall} - $w create line 175 197 175 227 -fill $color -tags {floor2 wall} - $w create line 757 206 757 221 -fill $color -tags {floor2 wall} - $w create line 396 188 408 188 -fill $color -tags {floor2 wall} - $w create line 727 189 725 189 -fill $color -tags {floor2 wall} - $w create line 747 167 802 167 -fill $color -tags {floor2 wall} - $w create line 747 167 747 189 -fill $color -tags {floor2 wall} - $w create line 755 189 739 189 -fill $color -tags {floor2 wall} - $w create line 769 224 757 224 -fill $color -tags {floor2 wall} - $w create line 802 224 802 129 -fill $color -tags {floor2 wall} - $w create line 802 129 725 129 -fill $color -tags {floor2 wall} - $w create line 725 189 725 129 -fill $color -tags {floor2 wall} - $w create line 725 186 690 186 -fill $color -tags {floor2 wall} - $w create line 676 133 676 186 -fill $color -tags {floor2 wall} - $w create line 627 144 627 186 -fill $color -tags {floor2 wall} - $w create line 629 186 593 186 -fill $color -tags {floor2 wall} - $w create line 579 144 579 186 -fill $color -tags {floor2 wall} - $w create line 559 129 559 133 -fill $color -tags {floor2 wall} - $w create line 725 133 559 133 -fill $color -tags {floor2 wall} - $w create line 484 162 484 129 -fill $color -tags {floor2 wall} - $w create line 559 129 484 129 -fill $color -tags {floor2 wall} - $w create line 526 129 526 186 -fill $color -tags {floor2 wall} - $w create line 540 186 581 186 -fill $color -tags {floor2 wall} - $w create line 528 186 523 186 -fill $color -tags {floor2 wall} - $w create line 511 186 475 186 -fill $color -tags {floor2 wall} - $w create line 496 190 496 186 -fill $color -tags {floor2 wall} - $w create line 496 205 496 202 -fill $color -tags {floor2 wall} - $w create line 475 205 527 205 -fill $color -tags {floor2 wall} - $w create line 558 205 539 205 -fill $color -tags {floor2 wall} - $w create line 558 205 558 249 -fill $color -tags {floor2 wall} - $w create line 558 249 475 249 -fill $color -tags {floor2 wall} - $w create line 662 206 642 206 -fill $color -tags {floor2 wall} - $w create line 695 206 675 206 -fill $color -tags {floor2 wall} - $w create line 695 278 642 278 -fill $color -tags {floor2 wall} - $w create line 642 291 642 206 -fill $color -tags {floor2 wall} - $w create line 695 291 695 206 -fill $color -tags {floor2 wall} - $w create line 716 208 716 206 -fill $color -tags {floor2 wall} - $w create line 757 206 716 206 -fill $color -tags {floor2 wall} - $w create line 757 221 757 224 -fill $color -tags {floor2 wall} - $w create line 793 224 802 224 -fill $color -tags {floor2 wall} - $w create line 757 262 716 262 -fill $color -tags {floor2 wall} - $w create line 716 220 716 264 -fill $color -tags {floor2 wall} - $w create line 716 315 716 276 -fill $color -tags {floor2 wall} - $w create line 757 315 703 315 -fill $color -tags {floor2 wall} - $w create line 757 325 757 224 -fill $color -tags {floor2 wall} - $w create line 757 367 644 367 -fill $color -tags {floor2 wall} - $w create line 689 367 689 315 -fill $color -tags {floor2 wall} - $w create line 647 315 644 315 -fill $color -tags {floor2 wall} - $w create line 659 315 691 315 -fill $color -tags {floor2 wall} - $w create line 600 325 600 391 -fill $color -tags {floor2 wall} - $w create line 627 325 644 325 -fill $color -tags {floor2 wall} - $w create line 644 391 644 315 -fill $color -tags {floor2 wall} - $w create line 615 325 575 325 -fill $color -tags {floor2 wall} - $w create line 644 391 558 391 -fill $color -tags {floor2 wall} - $w create line 563 325 558 325 -fill $color -tags {floor2 wall} - $w create line 558 391 558 314 -fill $color -tags {floor2 wall} - $w create line 558 327 508 327 -fill $color -tags {floor2 wall} - $w create line 558 275 484 275 -fill $color -tags {floor2 wall} - $w create line 558 302 558 275 -fill $color -tags {floor2 wall} - $w create line 508 327 508 311 -fill $color -tags {floor2 wall} - $w create line 484 311 508 311 -fill $color -tags {floor2 wall} - $w create line 484 275 484 311 -fill $color -tags {floor2 wall} - $w create line 475 208 408 208 -fill $color -tags {floor2 wall} - $w create line 408 206 408 210 -fill $color -tags {floor2 wall} - $w create line 408 222 408 227 -fill $color -tags {floor2 wall} - $w create line 408 227 398 227 -fill $color -tags {floor2 wall} - $w create line 398 227 398 254 -fill $color -tags {floor2 wall} - $w create line 408 188 408 194 -fill $color -tags {floor2 wall} - $w create line 383 188 376 188 -fill $color -tags {floor2 wall} - $w create line 398 188 398 162 -fill $color -tags {floor2 wall} - $w create line 398 162 484 162 -fill $color -tags {floor2 wall} - $w create line 475 162 475 254 -fill $color -tags {floor2 wall} - $w create line 398 254 475 254 -fill $color -tags {floor2 wall} - $w create line 484 280 395 280 -fill $color -tags {floor2 wall} - $w create line 395 311 395 275 -fill $color -tags {floor2 wall} - $w create line 307 197 293 197 -fill $color -tags {floor2 wall} - $w create line 278 197 233 197 -fill $color -tags {floor2 wall} - $w create line 233 197 233 249 -fill $color -tags {floor2 wall} - $w create line 307 179 284 179 -fill $color -tags {floor2 wall} - $w create line 233 249 278 249 -fill $color -tags {floor2 wall} - $w create line 269 179 269 133 -fill $color -tags {floor2 wall} - $w create line 220 179 220 133 -fill $color -tags {floor2 wall} - $w create line 155 191 110 191 -fill $color -tags {floor2 wall} - $w create line 90 190 98 190 -fill $color -tags {floor2 wall} - $w create line 98 169 98 190 -fill $color -tags {floor2 wall} - $w create line 52 133 52 165 -fill $color -tags {floor2 wall} - $w create line 52 214 52 177 -fill $color -tags {floor2 wall} - $w create line 52 226 52 262 -fill $color -tags {floor2 wall} - $w create line 52 274 52 276 -fill $color -tags {floor2 wall} - $w create line 234 275 234 339 -fill $color -tags {floor2 wall} - $w create line 226 339 258 339 -fill $color -tags {floor2 wall} - $w create line 211 387 211 339 -fill $color -tags {floor2 wall} - $w create line 214 339 177 339 -fill $color -tags {floor2 wall} - $w create line 258 387 60 387 -fill $color -tags {floor2 wall} - $w create line 3 133 3 339 -fill $color -tags {floor2 wall} - $w create line 165 339 129 339 -fill $color -tags {floor2 wall} - $w create line 117 339 80 339 -fill $color -tags {floor2 wall} - $w create line 68 339 59 339 -fill $color -tags {floor2 wall} - $w create line 0 339 46 339 -fill $color -tags {floor2 wall} - $w create line 60 391 0 391 -fill $color -tags {floor2 wall} - $w create line 0 339 0 391 -fill $color -tags {floor2 wall} - $w create line 60 387 60 391 -fill $color -tags {floor2 wall} - $w create line 258 329 258 387 -fill $color -tags {floor2 wall} - $w create line 350 329 258 329 -fill $color -tags {floor2 wall} - $w create line 395 311 350 311 -fill $color -tags {floor2 wall} - $w create line 398 129 315 129 -fill $color -tags {floor2 wall} - $w create line 176 133 315 133 -fill $color -tags {floor2 wall} - $w create line 176 129 96 129 -fill $color -tags {floor2 wall} - $w create line 3 133 96 133 -fill $color -tags {floor2 wall} - $w create line 66 387 66 339 -fill $color -tags {floor2 wall} - $w create line 115 387 115 339 -fill $color -tags {floor2 wall} - $w create line 163 387 163 339 -fill $color -tags {floor2 wall} - $w create line 234 275 276 275 -fill $color -tags {floor2 wall} - $w create line 288 275 309 275 -fill $color -tags {floor2 wall} - $w create line 298 275 298 329 -fill $color -tags {floor2 wall} - $w create line 341 283 350 283 -fill $color -tags {floor2 wall} - $w create line 321 275 341 275 -fill $color -tags {floor2 wall} - $w create line 375 275 395 275 -fill $color -tags {floor2 wall} - $w create line 315 129 315 170 -fill $color -tags {floor2 wall} - $w create line 376 170 307 170 -fill $color -tags {floor2 wall} - $w create line 307 250 307 170 -fill $color -tags {floor2 wall} - $w create line 376 245 376 170 -fill $color -tags {floor2 wall} - $w create line 340 241 307 241 -fill $color -tags {floor2 wall} - $w create line 340 245 340 224 -fill $color -tags {floor2 wall} - $w create line 340 210 340 201 -fill $color -tags {floor2 wall} - $w create line 340 187 340 170 -fill $color -tags {floor2 wall} - $w create line 340 206 307 206 -fill $color -tags {floor2 wall} - $w create line 293 250 307 250 -fill $color -tags {floor2 wall} - $w create line 271 179 238 179 -fill $color -tags {floor2 wall} - $w create line 226 179 195 179 -fill $color -tags {floor2 wall} - $w create line 176 129 176 179 -fill $color -tags {floor2 wall} - $w create line 182 179 176 179 -fill $color -tags {floor2 wall} - $w create line 174 169 176 169 -fill $color -tags {floor2 wall} - $w create line 162 169 90 169 -fill $color -tags {floor2 wall} - $w create line 96 169 96 129 -fill $color -tags {floor2 wall} - $w create line 175 227 90 227 -fill $color -tags {floor2 wall} - $w create line 90 190 90 227 -fill $color -tags {floor2 wall} - $w create line 52 179 3 179 -fill $color -tags {floor2 wall} - $w create line 52 228 3 228 -fill $color -tags {floor2 wall} - $w create line 52 276 3 276 -fill $color -tags {floor2 wall} - $w create line 155 177 155 169 -fill $color -tags {floor2 wall} - $w create line 110 191 110 169 -fill $color -tags {floor2 wall} - $w create line 155 189 155 197 -fill $color -tags {floor2 wall} - $w create line 350 283 350 329 -fill $color -tags {floor2 wall} - $w create line 162 197 155 197 -fill $color -tags {floor2 wall} - $w create line 341 275 341 283 -fill $color -tags {floor2 wall} -} - -# fg3 -- -# This procedure represents part of the floorplan database. When -# invoked, it instantiates the foreground information for the third -# floor (office outlines and numbers). -# -# Arguments: -# w - The canvas window. -# color - Color to use for drawing foreground information. - -proc fg3 {w color} { - global floorLabels floorItems - set i [$w create polygon 89 228 89 180 70 180 70 228 -fill {} -tags {floor3 room}] - set floorLabels($i) 316 - set {floorItems(316)} $i - $w create text 79.5 204 -text 316 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 115 368 162 368 162 323 115 323 -fill {} -tags {floor3 room}] - set floorLabels($i) 309 - set {floorItems(309)} $i - $w create text 138.5 345.5 -text 309 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 164 323 164 368 211 368 211 323 -fill {} -tags {floor3 room}] - set floorLabels($i) 308 - set {floorItems(308)} $i - $w create text 187.5 345.5 -text 308 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 256 368 212 368 212 323 256 323 -fill {} -tags {floor3 room}] - set floorLabels($i) 307 - set {floorItems(307)} $i - $w create text 234 345.5 -text 307 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 244 276 297 276 297 327 260 327 260 321 244 321 -fill {} -tags {floor3 room}] - set floorLabels($i) 305 - set {floorItems(305)} $i - $w create text 270.5 301.5 -text 305 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 251 219 251 203 244 203 244 219 -fill {} -tags {floor3 room}] - set floorLabels($i) 324B - set {floorItems(324B)} $i - $w create text 247.5 211 -text 324B -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 251 249 244 249 244 232 251 232 -fill {} -tags {floor3 room}] - set floorLabels($i) 324A - set {floorItems(324A)} $i - $w create text 247.5 240.5 -text 324A -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 223 135 223 179 177 179 177 135 -fill {} -tags {floor3 room}] - set floorLabels($i) 320 - set {floorItems(320)} $i - $w create text 200 157 -text 320 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 114 368 114 323 67 323 67 368 -fill {} -tags {floor3 room}] - set floorLabels($i) 310 - set {floorItems(310)} $i - $w create text 90.5 345.5 -text 310 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 23 277 23 321 68 321 68 277 -fill {} -tags {floor3 room}] - set floorLabels($i) 312 - set {floorItems(312)} $i - $w create text 45.5 299 -text 312 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 23 229 68 229 68 275 23 275 -fill {} -tags {floor3 room}] - set floorLabels($i) 313 - set {floorItems(313)} $i - $w create text 45.5 252 -text 313 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 68 227 23 227 23 180 68 180 -fill {} -tags {floor3 room}] - set floorLabels($i) 314 - set {floorItems(314)} $i - $w create text 45.5 203.5 -text 314 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 95 179 95 135 23 135 23 179 -fill {} -tags {floor3 room}] - set floorLabels($i) 315 - set {floorItems(315)} $i - $w create text 59 157 -text 315 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 99 226 99 204 91 204 91 226 -fill {} -tags {floor3 room}] - set floorLabels($i) 316B - set {floorItems(316B)} $i - $w create text 95 215 -text 316B -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 91 202 99 202 99 180 91 180 -fill {} -tags {floor3 room}] - set floorLabels($i) 316A - set {floorItems(316A)} $i - $w create text 95 191 -text 316A -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 97 169 109 169 109 192 154 192 154 198 174 198 174 226 101 226 101 179 97 179 -fill {} -tags {floor3 room}] - set floorLabels($i) 319 - set {floorItems(319)} $i - $w create text 141.5 209 -text 319 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 65 368 58 368 58 389 1 389 1 333 23 333 23 323 65 323 -fill {} -tags {floor3 room}] - set floorLabels($i) 311 - set {floorItems(311)} $i - $w create text 29.5 361 -text 311 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 154 191 111 191 111 169 154 169 -fill {} -tags {floor3 room}] - set floorLabels($i) 318 - set {floorItems(318)} $i - $w create text 132.5 180 -text 318 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 175 168 97 168 97 131 175 131 -fill {} -tags {floor3 room}] - set floorLabels($i) 317 - set {floorItems(317)} $i - $w create text 136 149.5 -text 317 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 274 194 274 221 306 221 306 194 -fill {} -tags {floor3 room}] - set floorLabels($i) 323 - set {floorItems(323)} $i - $w create text 290 207.5 -text 323 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 306 222 274 222 274 249 306 249 -fill {} -tags {floor3 room}] - set floorLabels($i) 325 - set {floorItems(325)} $i - $w create text 290 235.5 -text 325 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 263 179 224 179 224 135 263 135 -fill {} -tags {floor3 room}] - set floorLabels($i) 321 - set {floorItems(321)} $i - $w create text 243.5 157 -text 321 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 314 169 306 169 306 192 273 192 264 181 264 135 314 135 -fill {} -tags {floor3 room}] - set floorLabels($i) 322 - set {floorItems(322)} $i - $w create text 293.5 163.5 -text 322 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -tags {floor3 room}] - set floorLabels($i) {Pub Lift3} - set {floorItems(Pub Lift3)} $i - $w create text 323 223 -text {Pub Lift3} -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -tags {floor3 room}] - set floorLabels($i) {Priv Lift3} - set {floorItems(Priv Lift3)} $i - $w create text 323 188 -text {Priv Lift3} -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 350 284 376 284 376 276 397 276 397 309 350 309 -fill {} -tags {floor3 room}] - set floorLabels($i) 303 - set {floorItems(303)} $i - $w create text 373.5 292.5 -text 303 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 272 203 272 249 252 249 252 230 244 230 244 221 252 221 252 203 -fill {} -tags {floor3 room}] - set floorLabels($i) 324 - set {floorItems(324)} $i - $w create text 262 226 -text 324 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 299 276 299 327 349 327 349 284 341 284 341 276 -fill {} -tags {floor3 room}] - set floorLabels($i) 304 - set {floorItems(304)} $i - $w create text 324 301.5 -text 304 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor3 room}] - set floorLabels($i) 301 - set {floorItems(301)} $i - $w create text 358 209 -text 301 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 397 246 377 246 377 185 397 185 -fill {} -tags {floor3 room}] - set floorLabels($i) 327 - set {floorItems(327)} $i - $w create text 387 215.5 -text 327 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 316 131 316 169 377 169 377 185 397 185 397 131 -fill {} -tags {floor3 room}] - set floorLabels($i) 326 - set {floorItems(326)} $i - $w create text 356.5 150 -text 326 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 308 251 242 251 242 274 342 274 342 282 375 282 375 274 397 274 397 248 339 248 339 242 308 242 -fill {} -tags {floor3 room}] - set floorLabels($i) 302 - set {floorItems(302)} $i - $w create text 319.5 261 -text 302 -fill $color -anchor c -tags {floor3 label} - set i [$w create polygon 70 321 242 321 242 200 259 200 259 203 272 203 272 193 263 180 242 180 175 180 175 169 156 169 156 196 177 196 177 228 107 228 70 228 70 275 107 275 107 248 160 248 160 301 107 301 107 275 70 275 -fill {} -tags {floor3 room}] - set floorLabels($i) 306 - set {floorItems(306)} $i - $w create text 200.5 284.5 -text 306 -fill $color -anchor c -tags {floor3 label} - $w create line 341 275 341 283 -fill $color -tags {floor3 wall} - $w create line 162 197 155 197 -fill $color -tags {floor3 wall} - $w create line 396 247 399 247 -fill $color -tags {floor3 wall} - $w create line 399 129 399 311 -fill $color -tags {floor3 wall} - $w create line 258 202 243 202 -fill $color -tags {floor3 wall} - $w create line 350 283 350 329 -fill $color -tags {floor3 wall} - $w create line 251 231 243 231 -fill $color -tags {floor3 wall} - $w create line 243 220 251 220 -fill $color -tags {floor3 wall} - $w create line 243 250 243 202 -fill $color -tags {floor3 wall} - $w create line 155 197 155 190 -fill $color -tags {floor3 wall} - $w create line 110 192 110 169 -fill $color -tags {floor3 wall} - $w create line 155 192 110 192 -fill $color -tags {floor3 wall} - $w create line 155 177 155 169 -fill $color -tags {floor3 wall} - $w create line 176 197 176 227 -fill $color -tags {floor3 wall} - $w create line 69 280 69 274 -fill $color -tags {floor3 wall} - $w create line 21 276 69 276 -fill $color -tags {floor3 wall} - $w create line 69 262 69 226 -fill $color -tags {floor3 wall} - $w create line 21 228 69 228 -fill $color -tags {floor3 wall} - $w create line 21 179 75 179 -fill $color -tags {floor3 wall} - $w create line 69 179 69 214 -fill $color -tags {floor3 wall} - $w create line 90 220 90 227 -fill $color -tags {floor3 wall} - $w create line 90 204 90 202 -fill $color -tags {floor3 wall} - $w create line 90 203 100 203 -fill $color -tags {floor3 wall} - $w create line 90 187 90 179 -fill $color -tags {floor3 wall} - $w create line 90 227 176 227 -fill $color -tags {floor3 wall} - $w create line 100 179 100 227 -fill $color -tags {floor3 wall} - $w create line 100 179 87 179 -fill $color -tags {floor3 wall} - $w create line 96 179 96 129 -fill $color -tags {floor3 wall} - $w create line 162 169 96 169 -fill $color -tags {floor3 wall} - $w create line 173 169 176 169 -fill $color -tags {floor3 wall} - $w create line 182 179 176 179 -fill $color -tags {floor3 wall} - $w create line 176 129 176 179 -fill $color -tags {floor3 wall} - $w create line 195 179 226 179 -fill $color -tags {floor3 wall} - $w create line 224 133 224 179 -fill $color -tags {floor3 wall} - $w create line 264 179 264 133 -fill $color -tags {floor3 wall} - $w create line 238 179 264 179 -fill $color -tags {floor3 wall} - $w create line 273 207 273 193 -fill $color -tags {floor3 wall} - $w create line 273 235 273 250 -fill $color -tags {floor3 wall} - $w create line 273 224 273 219 -fill $color -tags {floor3 wall} - $w create line 273 193 307 193 -fill $color -tags {floor3 wall} - $w create line 273 222 307 222 -fill $color -tags {floor3 wall} - $w create line 273 250 307 250 -fill $color -tags {floor3 wall} - $w create line 384 247 376 247 -fill $color -tags {floor3 wall} - $w create line 340 206 307 206 -fill $color -tags {floor3 wall} - $w create line 340 187 340 170 -fill $color -tags {floor3 wall} - $w create line 340 210 340 201 -fill $color -tags {floor3 wall} - $w create line 340 247 340 224 -fill $color -tags {floor3 wall} - $w create line 340 241 307 241 -fill $color -tags {floor3 wall} - $w create line 376 247 376 170 -fill $color -tags {floor3 wall} - $w create line 307 250 307 170 -fill $color -tags {floor3 wall} - $w create line 376 170 307 170 -fill $color -tags {floor3 wall} - $w create line 315 129 315 170 -fill $color -tags {floor3 wall} - $w create line 376 283 366 283 -fill $color -tags {floor3 wall} - $w create line 376 283 376 275 -fill $color -tags {floor3 wall} - $w create line 399 275 376 275 -fill $color -tags {floor3 wall} - $w create line 341 275 320 275 -fill $color -tags {floor3 wall} - $w create line 341 283 350 283 -fill $color -tags {floor3 wall} - $w create line 298 275 298 329 -fill $color -tags {floor3 wall} - $w create line 308 275 298 275 -fill $color -tags {floor3 wall} - $w create line 243 322 243 275 -fill $color -tags {floor3 wall} - $w create line 243 275 284 275 -fill $color -tags {floor3 wall} - $w create line 258 322 226 322 -fill $color -tags {floor3 wall} - $w create line 212 370 212 322 -fill $color -tags {floor3 wall} - $w create line 214 322 177 322 -fill $color -tags {floor3 wall} - $w create line 163 370 163 322 -fill $color -tags {floor3 wall} - $w create line 165 322 129 322 -fill $color -tags {floor3 wall} - $w create line 84 322 117 322 -fill $color -tags {floor3 wall} - $w create line 71 322 64 322 -fill $color -tags {floor3 wall} - $w create line 115 322 115 370 -fill $color -tags {floor3 wall} - $w create line 66 322 66 370 -fill $color -tags {floor3 wall} - $w create line 52 322 21 322 -fill $color -tags {floor3 wall} - $w create line 21 331 0 331 -fill $color -tags {floor3 wall} - $w create line 21 331 21 133 -fill $color -tags {floor3 wall} - $w create line 96 133 21 133 -fill $color -tags {floor3 wall} - $w create line 176 129 96 129 -fill $color -tags {floor3 wall} - $w create line 315 133 176 133 -fill $color -tags {floor3 wall} - $w create line 315 129 399 129 -fill $color -tags {floor3 wall} - $w create line 399 311 350 311 -fill $color -tags {floor3 wall} - $w create line 350 329 258 329 -fill $color -tags {floor3 wall} - $w create line 258 322 258 370 -fill $color -tags {floor3 wall} - $w create line 60 370 258 370 -fill $color -tags {floor3 wall} - $w create line 60 370 60 391 -fill $color -tags {floor3 wall} - $w create line 0 391 0 331 -fill $color -tags {floor3 wall} - $w create line 60 391 0 391 -fill $color -tags {floor3 wall} - $w create line 307 250 307 242 -fill $color -tags {floor3 wall} - $w create line 273 250 307 250 -fill $color -tags {floor3 wall} - $w create line 258 250 243 250 -fill $color -tags {floor3 wall} -} - -# Below is the "main program" that creates the floorplan demonstration. - -set w .floor -global c currentRoom colors activeFloor -catch {destroy $w} -toplevel $w -wm title $w "Floorplan Canvas Demonstration" -wm iconname $w "Floorplan" -wm geometry $w +20+20 -wm minsize $w 100 100 - -label $w.msg -font $font -wraplength 8i -justify left -text "This window contains a canvas widget showing the floorplan of Digital Equipment Corporation's Western Research Laboratory. It has three levels. At any given time one of the levels is active, meaning that you can see its room structure. To activate a level, click the left mouse button anywhere on it. As the mouse moves over the active level, the room under the mouse lights up and its room number appears in the \"Room:\" entry. You can also type a room number in the entry and the room will light up." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -set f [frame $w.frame] -pack $f -side top -fill both -expand yes -set h [ttk::scrollbar $f.hscroll -orient horizontal] -set v [ttk::scrollbar $f.vscroll -orient vertical] -set f1 [frame $f.f1 -borderwidth 2 -relief sunken] -set c [canvas $f1.c -width 900 -height 500 -highlightthickness 0 \ - -xscrollcommand [list $h set] \ - -yscrollcommand [list $v set]] -pack $c -expand yes -fill both -grid $f1 -padx 1 -pady 1 -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news -grid $v -padx 1 -pady 1 -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news -grid $h -padx 1 -pady 1 -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news -grid rowconfig $f 0 -weight 1 -minsize 0 -grid columnconfig $f 0 -weight 1 -minsize 0 -pack $f -expand yes -fill both -padx 1 -pady 1 - -$v configure -command [list $c yview] -$h configure -command [list $c xview] - -# Create an entry for displaying and typing in current room. - -entry $c.entry -width 10 -textvariable currentRoom - -# Choose colors, then fill in the floorplan. - -if {[winfo depth $c] > 1} { - set colors(bg1) #a9c1da - set colors(outline1) #77889a - set colors(bg2) #9ab0c6 - set colors(outline2) #687786 - set colors(bg3) #8ba0b3 - set colors(outline3) #596673 - set colors(offices) Black - set colors(active) #c4d1df -} else { - set colors(bg1) white - set colors(outline1) black - set colors(bg2) white - set colors(outline2) black - set colors(bg3) white - set colors(outline3) black - set colors(offices) Black - set colors(active) black -} -set activeFloor "" -floorDisplay $c 3 - -# Set up event bindings for canvas: - -$c bind floor1 <1> "floorDisplay $c 1" -$c bind floor2 <1> "floorDisplay $c 2" -$c bind floor3 <1> "floorDisplay $c 3" -$c bind room <Enter> "newRoom $c" -$c bind room <Leave> {set currentRoom ""} -bind $c <2> "$c scan mark %x %y" -bind $c <B2-Motion> "$c scan dragto %x %y" -bind $c <Destroy> "unset currentRoom" -set currentRoom "" -trace variable currentRoom w "roomChanged $c" diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/fontchoose.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/fontchoose.tcl @@ -1,69 +0,0 @@ -# fontchoose.tcl -- -# -# Show off the stock font selector dialog - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .fontchoose -catch {destroy $w} -toplevel $w -wm title $w "Font Selection Dialog" -wm iconname $w "fontchooser" -positionWindow $w - -catch {font create FontchooseDemoFont {*}[font actual TkDefaultFont]} - -# The font chooser needs to be configured and then shown. -proc SelectFont {parent} { - tk fontchooser configure -font FontchooseDemoFont \ - -command ApplyFont -parent $parent - tk fontchooser show -} - -proc ApplyFont {font} { - font configure FontchooseDemoFont {*}[font actual $font] -} - -# When the visibility of the fontchooser changes, the following event is fired -# to the parent widget. -# -bind $w <<TkFontchooserVisibility>> { - if {[tk fontchooser configure -visible]} { - %W.f.font state disabled - } else { - %W.f.font state !disabled - } -} - - -set f [ttk::frame $w.f -relief sunken -padding 2] - -text $f.msg -font FontchooseDemoFont -width 40 -height 6 -borderwidth 0 \ - -yscrollcommand [list $f.vs set] -ttk::scrollbar $f.vs -command [list $f.msg yview] - -$f.msg insert end "Press the buttons below to choose a new font for the\ - text shown in this window.\n" {} - -ttk::button $f.font -text "Set font ..." -command [list SelectFont $w] - -grid $f.msg $f.vs -sticky news -grid $f.font - -sticky e -grid columnconfigure $f 0 -weight 1 -grid rowconfigure $f 0 -weight 1 -bind $w <Visibility> { - bind %W <Visibility> {} - grid propagate %W.f 0 -} - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] - -grid $f -sticky news -grid $btns -sticky ew -grid columnconfigure $w 0 -weight 1 -grid rowconfigure $w 0 -weight 1 diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/form.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/form.tcl @@ -1,38 +0,0 @@ -# form.tcl -- -# -# This demonstration script creates a simple form with a bunch -# of entry widgets. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .form -catch {destroy $w} -toplevel $w -wm title $w "Form Demonstration" -wm iconname $w "form" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "This window contains a simple form where you can type in the various entries and use tabs to move circularly between the entries." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -foreach i {f1 f2 f3 f4 f5} { - frame $w.$i -bd 2 - entry $w.$i.entry -relief sunken -width 40 - label $w.$i.label - pack $w.$i.entry -side right - pack $w.$i.label -side left -} -$w.f1.label config -text Name: -$w.f2.label config -text Address: -$w.f5.label config -text Phone: -pack $w.msg $w.f1 $w.f2 $w.f3 $w.f4 $w.f5 -side top -fill x -bind $w <Return> "destroy $w" -focus $w.f1.entry diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/goldberg.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/goldberg.tcl @@ -1,1833 +0,0 @@ -##+################################################################# -# -# TkGoldberg.tcl -# by Keith Vetter, March 13, 2003 -# -# "Man will always find a difficult means to perform a simple task" -# Rube Goldberg -# -# Reproduced here with permission. -# -##+################################################################# -# -# Keith Vetter 2003-03-21: this started out as a simple little program -# but was so much fun that it grew and grew. So I apologize about the -# size but I just couldn't resist sharing it. -# -# This is a whizzlet that does a Rube Goldberg type animation, the -# design of which comes from an New Years e-card from IncrediMail. -# That version had nice sound effects which I eschewed. On the other -# hand, that version was in black and white (actually dark blue and -# light blue) and this one is fully colorized. -# -# One thing I learned from this project is that drawing filled complex -# objects on a canvas is really hard. More often than not I had to -# draw each item twice--once with the desired fill color but no -# outline, and once with no fill but with the outline. Another trick -# is erasing by drawing with the background color. Having a flood fill -# command would have been extremely helpful. -# -# Two wiki pages were extremely helpful: Drawing rounded rectangles -# which I generalized into Drawing rounded polygons, and regular -# polygons which allowed me to convert ovals and arcs into polygons -# which could then be rotated (see Canvas Rotation). I also wrote -# Named Colors to aid in the color selection. -# -# I could comment on the code, but it's just 26 state machines with -# lots of canvas create and move calls. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .goldberg -catch {destroy $w} -toplevel $w -wm title $w "Tk Goldberg (demonstration)" -wm iconname $w "goldberg" -wm resizable $w 0 0 -#positionWindow $w - -label $w.msg -font {Arial 10} -wraplength 4i -justify left -text "This is a\ - demonstration of just how complex you can make your animations\ - become. Click the ball to start things moving!\n\n\"Man will always\ - find a difficult means to perform a simple task\"\n - Rube Goldberg" -pack $w.msg -side top - -###--- End of Boilerplate ---### - -# Ensure that this this is an array -array set animationCallbacks {} -bind $w <Destroy> { - if {"%W" eq [winfo toplevel %W]} { - unset S C speed - } -} - -set S(title) "Tk Goldberg" -set S(speed) 5 -set S(cnt) 0 -set S(message) "\\nWelcome\\nto\\nTcl/Tk" -array set speed {1 10 2 20 3 50 4 80 5 100 6 150 7 200 8 300 9 400 10 500} - -set MSTART 0; set MGO 1; set MPAUSE 2; set MSSTEP 3; set MBSTEP 4; set MDONE 5 -set S(mode) $::MSTART - -# Colors for everything -set C(fg) black -set C(bg) gray75 -set C(bg) cornflowerblue - -set C(0) white; set C(1a) darkgreen; set C(1b) yellow -set C(2) red; set C(3a) green; set C(3b) darkblue -set C(4) $C(fg); set C(5a) brown; set C(5b) white -set C(6) magenta; set C(7) green; set C(8) $C(fg) -set C(9) blue4; set C(10a) white; set C(10b) cyan -set C(11a) yellow; set C(11b) mediumblue; set C(12) tan2 -set C(13a) yellow; set C(13b) red; set C(14) white -set C(15a) green; set C(15b) yellow; set C(16) gray65 -set C(17) \#A65353; set C(18) $C(fg); set C(19) gray50 -set C(20) cyan; set C(21) gray65; set C(22) $C(20) -set C(23a) blue; set C(23b) red; set C(23c) yellow -set C(24a) red; set C(24b) white; - -proc DoDisplay {w} { - global S C - - ttk::frame $w.ctrl -relief ridge -borderwidth 2 -padding 5 - pack [frame $w.screen -bd 2 -relief raised] \ - -side left -fill both -expand 1 - - canvas $w.c -width 860 -height 730 -bg $C(bg) -highlightthickness 0 - $w.c config -scrollregion {0 0 1000 1000} ;# Kludge: move everything up - $w.c yview moveto .05 - pack $w.c -in $w.screen -side top -fill both -expand 1 - - bind $w.c <3> [list $w.pause invoke] - bind $w.c <Destroy> { - after cancel $animationCallbacks(goldberg) - unset animationCallbacks(goldberg) - } - DoCtrlFrame $w - DoDetailFrame $w - if {[tk windowingsystem] ne "aqua"} { - ttk::button $w.show -text "\u00bb" -command [list ShowCtrl $w] -width 2 - } else { - button $w.show -text "\u00bb" -command [list ShowCtrl $w] -width 2 -highlightbackground $C(bg) - } - place $w.show -in $w.c -relx 1 -rely 0 -anchor ne - update -} - -proc DoCtrlFrame {w} { - global S - ttk::button $w.start -text "Start" -command [list DoButton $w 0] - ttk::checkbutton $w.pause -text "Pause" -command [list DoButton $w 1] \ - -variable S(pause) - ttk::button $w.step -text "Single Step" -command [list DoButton $w 2] - ttk::button $w.bstep -text "Big Step" -command [list DoButton $w 4] - ttk::button $w.reset -text "Reset" -command [list DoButton $w 3] - ttk::labelframe $w.details - raise $w.details - set S(details) 0 - ttk::checkbutton $w.details.cb -text "Details" -variable S(details) - ttk::labelframe $w.message -text "Message" - ttk::entry $w.message.e -textvariable S(message) -justify center - ttk::labelframe $w.speed -text "Speed: 0" - ttk::scale $w.speed.scale -orient h -from 1 -to 10 -variable S(speed) - ttk::button $w.about -text About -command [list About $w] - - grid $w.start -in $w.ctrl -row 0 -sticky ew - grid rowconfigure $w.ctrl 1 -minsize 10 - grid $w.pause -in $w.ctrl -row 2 -sticky ew - grid $w.step -in $w.ctrl -sticky ew -pady 2 - grid $w.bstep -in $w.ctrl -sticky ew - grid $w.reset -in $w.ctrl -sticky ew -pady 2 - grid rowconfigure $w.ctrl 10 -minsize 18 - grid $w.details -in $w.ctrl -row 11 -sticky ew - grid rowconfigure $w.ctrl 11 -minsize 20 - $w.details configure -labelwidget $w.details.cb - grid [ttk::frame $w.details.b -height 1] ;# Work around minor bug - raise $w.details - raise $w.details.cb - grid rowconfigure $w.ctrl 50 -weight 1 - trace variable ::S(mode) w [list ActiveGUI $w] - trace variable ::S(details) w [list ActiveGUI $w] - trace variable ::S(speed) w [list ActiveGUI $w] - - grid $w.message -in $w.ctrl -row 98 -sticky ew -pady 5 - grid $w.message.e -sticky nsew - grid $w.speed -in $w.ctrl -row 99 -sticky ew -pady {0 5} - pack $w.speed.scale -fill both -expand 1 - grid $w.about -in $w.ctrl -row 100 -sticky ew - bind $w.reset <3> {set S(mode) -1} ;# Debugging - - ## See Code / Dismiss buttons hack! - set btns [addSeeDismiss $w.ctrl.buttons $w] - grid [ttk::separator $w.ctrl.sep] -sticky ew -pady 4 - set i 0 - foreach b [winfo children $btns] { - if {[winfo class $b] eq "TButton"} { - grid [set b2 [ttk::button $w.ctrl.b[incr i]]] -sticky ew - foreach b3 [$b configure] { - set b3 [lindex $b3 0] - # Some options are read-only; ignore those errors - catch {$b2 configure $b3 [$b cget $b3]} - } - } - } - destroy $btns -} - -proc DoDetailFrame {w} { - set w2 $w.details.f - ttk::frame $w2 - - set bd 2 - ttk::label $w2.l -textvariable S(cnt) -background white - grid $w2.l - - - -sticky ew -row 0 - for {set i 1} {1} {incr i} { - if {[info procs "Move$i"] eq ""} break - ttk::label $w2.l$i -text $i -anchor e -width 2 -background white - ttk::label $w2.ll$i -textvariable STEP($i) -width 5 -background white - set row [expr {($i + 1) / 2}] - set col [expr {(($i + 1) & 1) * 2}] - grid $w2.l$i -sticky ew -row $row -column $col - grid $w2.ll$i -sticky ew -row $row -column [incr col] - } - grid columnconfigure $w2 1 -weight 1 -} - -# Map or unmap the ctrl window -proc ShowCtrl {w} { - if {[winfo ismapped $w.ctrl]} { - pack forget $w.ctrl - $w.show config -text "\u00bb" - } else { - pack $w.ctrl -side right -fill both -ipady 5 - $w.show config -text "\u00ab" - } -} - -proc DrawAll {w} { - ResetStep - $w.c delete all - for {set i 0} {1} {incr i} { - set p "Draw$i" - if {[info procs $p] eq ""} break - $p $w - } -} - -proc ActiveGUI {w var1 var2 op} { - global S MGO MSTART MDONE - array set z {0 disabled 1 normal} - - set m $S(mode) - set S(pause) [expr {$m == 2}] - $w.start config -state $z([expr {$m != $MGO}]) - $w.pause config -state $z([expr {$m != $MSTART && $m != $MDONE}]) - $w.step config -state $z([expr {$m != $MGO && $m != $MDONE}]) - $w.bstep config -state $z([expr {$m != $MGO && $m != $MDONE}]) - $w.reset config -state $z([expr {$m != $MSTART}]) - - if {$S(details)} { - grid $w.details.f -sticky ew - } else { - grid forget $w.details.f - } - set S(speed) [expr {round($S(speed))}] - $w.speed config -text "Speed: $S(speed)" -} - -proc Start {} { - global S MGO - set S(mode) $MGO -} - -proc DoButton {w what} { - global S MDONE MGO MSSTEP MBSTEP MPAUSE - - if {$what == 0} { ;# Start - if {$S(mode) == $MDONE} { - Reset $w - } - set S(mode) $MGO - } elseif {$what == 1} { ;# Pause - set S(mode) [expr {$S(pause) ? $MPAUSE : $MGO}] - } elseif {$what == 2} { ;# Step - set S(mode) $MSSTEP - } elseif {$what == 3} { ;# Reset - Reset $w - } elseif {$what == 4} { ;# Big step - set S(mode) $MBSTEP - } -} - -proc Go {w {who {}}} { - global S speed animationCallbacks MGO MPAUSE MSSTEP MBSTEP - - set now [clock clicks -milliseconds] - catch {after cancel $animationCallbacks(goldberg)} - if {$who ne ""} { ;# Start here for debugging - set S(active) $who; - set S(mode) $MGO - } - if {$S(mode) == -1} return ;# Debugging - set n 0 - if {$S(mode) != $MPAUSE} { ;# Not paused - set n [NextStep $w] ;# Do the next move - } - if {$S(mode) == $MSSTEP} { ;# Single step - set S(mode) $MPAUSE - } - if {$S(mode) == $MBSTEP && $n} { ;# Big step - set S(mode) $MSSTEP - } - - set elapsed [expr {[clock click -milliseconds] - $now}] - set delay [expr {$speed($S(speed)) - $elapsed}] - if {$delay <= 0} { - set delay 1 - } - set animationCallbacks(goldberg) [after $delay [list Go $w]] -} - -# NextStep: drives the next step of the animation -proc NextStep {w} { - global S MSTART MDONE - set rval 0 ;# Return value - - if {$S(mode) != $MSTART && $S(mode) != $MDONE} { - incr S(cnt) - } - set alive {} - foreach {who} $S(active) { - set n ["Move$who" $w] - if {$n & 1} { ;# This guy still alive - lappend alive $who - } - if {$n & 2} { ;# Next guy is active - lappend alive [expr {$who + 1}] - set rval 1 - } - if {$n & 4} { ;# End of puzzle flag - set S(mode) $MDONE ;# Done mode - set S(active) {} ;# No more animation - return 1 - } - } - set S(active) $alive - return $rval -} -proc About {w} { - set msg "$::S(title)\nby Keith Vetter, March 2003\n(Reproduced by kind\ - permission of the author)\n\n\"Man will always find a difficult\ - means to perform a simple task.\"\nRube Goldberg" - tk_messageBox -parent $w -message $msg -title About -} -################################################################ -# -# All the drawing and moving routines -# - -# START HERE! banner -proc Draw0 {w} { - set color $::C(0) - set xy {579 119} - $w.c create text $xy -text "START HERE!" -fill $color -anchor w \ - -tag I0 -font {{Times Roman} 12 italic bold} - set xy {719 119 763 119} - $w.c create line $xy -tag I0 -fill $color -width 5 -arrow last \ - -arrowshape {18 18 5} - $w.c bind I0 <1> Start -} -proc Move0 {w {step {}}} { - set step [GetStep 0 $step] - - if {$::S(mode) > $::MSTART} { ;# Start the ball rolling - MoveAbs $w I0 {-100 -100} ;# Hide the banner - return 2 - } - - set pos { - {673 119} {678 119} {683 119} {688 119} - {693 119} {688 119} {683 119} {678 119} - } - set step [expr {$step % [llength $pos]}] - MoveAbs $w I0 [lindex $pos $step] - return 1 -} - -# Dropping ball -proc Draw1 {w} { - set color $::C(1a) - set color2 $::C(1b) - set xy {844 133 800 133 800 346 820 346 820 168 844 168 844 133} - $w.c create poly $xy -width 3 -fill $color -outline {} - set xy {771 133 685 133 685 168 751 168 751 346 771 346 771 133} - $w.c create poly $xy -width 3 -fill $color -outline {} - - set xy [box 812 122 9] - $w.c create oval $xy -tag I1 -fill $color2 -outline {} - $w.c bind I1 <1> Start -} -proc Move1 {w {step {}}} { - set step [GetStep 1 $step] - set pos { - {807 122} {802 122} {797 123} {793 124} {789 129} {785 153} - {785 203} {785 278 x} {785 367} {810 392} {816 438} {821 503} - {824 585 y} {838 587} {848 593} {857 601} {-100 -100} - } - if {$step >= [llength $pos]} { - return 0 - } - set where [lindex $pos $step] - MoveAbs $w I1 $where - - if {[lindex $where 2] eq "y"} { - Move15a $w - } - if {[lindex $where 2] eq "x"} { - return 3 - } - return 1 -} - -# Lighting the match -proc Draw2 {w} { - set color red - set color $::C(2) - set xy {750 369 740 392 760 392} ;# Fulcrum - $w.c create poly $xy -fill $::C(fg) -outline $::C(fg) - set xy {628 335 660 383} ;# Strike box - $w.c create rect $xy -fill {} -outline $::C(fg) - for {set y 0} {$y < 3} {incr y} { - set yy [expr {335+$y*16}] - $w.c create bitmap 628 $yy -bitmap gray25 -anchor nw \ - -foreground $::C(fg) - $w.c create bitmap 644 $yy -bitmap gray25 -anchor nw \ - -foreground $::C(fg) - } - - set xy {702 366 798 366} ;# Lever - $w.c create line $xy -fill $::C(fg) -width 6 -tag I2_0 - set xy {712 363 712 355} ;# R strap - $w.c create line $xy -fill $::C(fg) -width 3 -tag I2_1 - set xy {705 363 705 355} ;# L strap - $w.c create line $xy -fill $::C(fg) -width 3 -tag I2_2 - set xy {679 356 679 360 717 360 717 356 679 356} ;# Match stick - $w.c create line $xy -fill $::C(fg) -tag I2_3 - - #set xy {662 352 680 365} ;# Match head - set xy { - 671 352 677.4 353.9 680 358.5 677.4 363.1 671 365 664.6 363.1 - 662 358.5 664.6 353.9 - } - $w.c create poly $xy -fill $color -outline $color -tag I2_4 -} -proc Move2 {w {step {}}} { - set step [GetStep 2 $step] - - set stages {0 0 1 2 0 2 1 0 1 2 0 2 1} - set xy(0) { - 686 333 692 323 682 316 674 309 671 295 668 307 662 318 662 328 - 671 336 - } - set xy(1) {687 331 698 322 703 295 680 320 668 297 663 311 661 327 671 335} - set xy(2) { - 686 331 704 322 688 300 678 283 678 283 674 298 666 309 660 324 - 672 336 - } - - if {$step >= [llength $stages]} { - $w.c delete I2 - return 0 - } - - if {$step == 0} { ;# Rotate the match - set beta 20 - lassign [Anchor $w I2_0 s] Ox Oy ;# Where to pivot - for {set i 0} {[$w.c find withtag I2_$i] ne ""} {incr i} { - RotateItem $w I2_$i $Ox $Oy $beta - } - $w.c create poly -tag I2 -smooth 1 -fill $::C(2) ;# For the flame - return 1 - } - $w.c coords I2 $xy([lindex $stages $step]) - return [expr {$step == 7 ? 3 : 1}] -} - -# Weight and pulleys -proc Draw3 {w} { - set color $::C(3a) - set color2 $::C(3b) - - set xy {602 296 577 174 518 174} - foreach {x y} $xy { ;# 3 Pulleys - $w.c create oval [box $x $y 13] -fill $color -outline $::C(fg) \ - -width 3 - $w.c create oval [box $x $y 2] -fill $::C(fg) -outline $::C(fg) - } - - set xy {750 309 670 309} ;# Wall to flame - $w.c create line $xy -tag I3_s -width 3 -fill $::C(fg) -smooth 1 - set xy {670 309 650 309} ;# Flame to pulley 1 - $w.c create line $xy -tag I3_0 -width 3 -fill $::C(fg) - set xy {650 309 600 309} ;# Flame to pulley 1 - $w.c create line $xy -tag I3_1 -width 3 -fill $::C(fg) - set xy {589 296 589 235} ;# Pulley 1 half way to 2 - $w.c create line $xy -tag I3_2 -width 3 -fill $::C(fg) - set xy {589 235 589 174} ;# Pulley 1 other half to 2 - $w.c create line $xy -width 3 -fill $::C(fg) - set xy {577 161 518 161} ;# Across the top - $w.c create line $xy -width 3 -fill $::C(fg) - set xy {505 174 505 205} ;# Down to weight - $w.c create line $xy -tag I3_w -width 3 -fill $::C(fg) - - # Draw the weight as 2 circles, two rectangles and 1 rounded rectangle - set xy {515 207 495 207} - foreach {x1 y1 x2 y2} $xy { - $w.c create oval [box $x1 $y1 6] -tag I3_ -fill $color2 \ - -outline $color2 - $w.c create oval [box $x2 $y2 6] -tag I3_ -fill $color2 \ - -outline $color2 - incr y1 -6; incr y2 6 - $w.c create rect $x1 $y1 $x2 $y2 -tag I3_ -fill $color2 \ - -outline $color2 - } - set xy {492 220 518 263} - set xy [RoundRect $w $xy 15] - $w.c create poly $xy -smooth 1 -tag I3_ -fill $color2 -outline $color2 - set xy {500 217 511 217} - $w.c create line $xy -tag I3_ -fill $color2 -width 10 - - set xy {502 393 522 393 522 465} ;# Bottom weight target - $w.c create line $xy -tag I3__ -fill $::C(fg) -join miter -width 10 -} -proc Move3 {w {step {}}} { - set step [GetStep 3 $step] - - set pos {{505 247} {505 297} {505 386.5} {505 386.5}} - set rope(0) {750 309 729 301 711 324 690 300} - set rope(1) {750 309 737 292 736 335 717 315 712 320} - set rope(2) {750 309 737 309 740 343 736 351 725 340} - set rope(3) {750 309 738 321 746 345 742 356} - - if {$step >= [llength $pos]} { - return 0 - } - - $w.c delete "I3_$step" ;# Delete part of the rope - MoveAbs $w I3_ [lindex $pos $step] ;# Move weight down - $w.c coords I3_s $rope($step) ;# Flapping rope end - $w.c coords I3_w [concat 505 174 [lindex $pos $step]] - if {$step == 2} { - $w.c move I3__ 0 30 - return 2 - } - return 1 -} - -# Cage and door -proc Draw4 {w} { - set color $::C(4) - lassign {527 356 611 464} x0 y0 x1 y1 - - for {set y $y0} {$y <= $y1} {incr y 12} { ;# Horizontal bars - $w.c create line $x0 $y $x1 $y -fill $color -width 1 - } - for {set x $x0} {$x <= $x1} {incr x 12} { ;# Vertical bars - $w.c create line $x $y0 $x $y1 -fill $color -width 1 - } - - set xy {518 464 518 428} ;# Swing gate - $w.c create line $xy -tag I4 -fill $color -width 3 -} -proc Move4 {w {step {}}} { - set step [GetStep 4 $step] - - set angles {-10 -20 -30 -30} - if {$step >= [llength $angles]} { - return 0 - } - RotateItem $w I4 518 464 [lindex $angles $step] - $w.c raise I4 - return [expr {$step == 3 ? 3 : 1}] -} - -# Mouse -proc Draw5 {w} { - set color $::C(5a) - set color2 $::C(5b) - set xy {377 248 410 248 410 465 518 465} ;# Mouse course - lappend xy 518 428 451 428 451 212 377 212 - $w.c create poly $xy -fill $color2 -outline $::C(fg) -width 3 - - set xy { - 534.5 445.5 541 440 552 436 560 436 569 440 574 446 575 452 574 454 - 566 456 554 456 545 456 537 454 530 452 - } - $w.c create poly $xy -tag {I5 I5_0} -fill $color - set xy {573 452 592 458 601 460 613 456} ;# Tail - $w.c create line $xy -tag {I5 I5_1} -fill $color -smooth 1 -width 3 - set xy [box 540 446 2] ;# Eye - set xy {540 444 541 445 541 447 540 448 538 447 538 445} - #.c create oval $xy -tag {I5 I5_2} -fill $::C(bg) -outline {} - $w.c create poly $xy -tag {I5 I5_2} -fill $::C(bg) -outline {} -smooth 1 - set xy {538 454 535 461} ;# Front leg - $w.c create line $xy -tag {I5 I5_3} -fill $color -width 2 - set xy {566 455 569 462} ;# Back leg - $w.c create line $xy -tag {I5 I5_4} -fill $color -width 2 - set xy {544 455 545 460} ;# 2nd front leg - $w.c create line $xy -tag {I5 I5_5} -fill $color -width 2 - set xy {560 455 558 460} ;# 2nd back leg - $w.c create line $xy -tag {I5 I5_6} -fill $color -width 2 -} -proc Move5 {w {step {}}} { - set step [GetStep 5 $step] - - set pos { - {553 452} {533 452} {513 452} {493 452} {473 452} - {463 442 30} {445.5 441.5 30} {425.5 434.5 30} {422 414} {422 394} - {422 374} {422 354} {422 334} {422 314} {422 294} - {422 274 -30} {422 260.5 -30 x} {422.5 248.5 -28} {425 237} - } - if {$step >= [llength $pos]} { - return 0 - } - - lassign [lindex $pos $step] x y beta next - MoveAbs $w I5 [list $x $y] - if {$beta ne ""} { - lassign [Centroid $w I5_0] Ox Oy - foreach id {0 1 2 3 4 5 6} { - RotateItem $w I5_$id $Ox $Oy $beta - } - } - if {$next eq "x"} { - return 3 - } - return 1 -} - -# Dropping gumballs -array set XY6 { - -1 {366 207} -2 {349 204} -3 {359 193} -4 {375 192} -5 {340 190} - -6 {349 177} -7 {366 177} -8 {380 176} -9 {332 172} -10 {342 161} - -11 {357 164} -12 {372 163} -13 {381 149} -14 {364 151} -15 {349 146} - -16 {333 148} 0 {357 219} - 1 {359 261} 2 {359 291} 3 {359 318} 4 {361 324} 5 {365 329} 6 {367 334} - 7 {367 340} 8 {366 346} 9 {364 350} 10 {361 355} 11 {359 370} 12 {359 391} - 13,0 {360 456} 13,1 {376 456} 13,2 {346 456} 13,3 {330 456} - 13,4 {353 444} 13,5 {368 443} 13,6 {339 442} 13,7 {359 431} - 13,8 {380 437} 13,9 {345 428} 13,10 {328 434} 13,11 {373 424} - 13,12 {331 420} 13,13 {360 417} 13,14 {345 412} 13,15 {376 410} - 13,16 {360 403} -} -proc Draw6 {w} { - set color $::C(6) - set xy {324 130 391 204} ;# Ball holder - set xy [RoundRect $w $xy 10] - $w.c create poly $xy -smooth 1 -outline $::C(fg) -width 3 -fill $color - set xy {339 204 376 253} ;# Below the ball holder - $w.c create rect $xy -fill {} -outline $::C(fg) -width 3 -fill $color \ - -tag I6c - set xy [box 346 339 28] - $w.c create oval $xy -fill $color -outline {} ;# Rotor - $w.c create arc $xy -outline $::C(fg) -width 2 -style arc \ - -start 80 -extent 205 - $w.c create arc $xy -outline $::C(fg) -width 2 -style arc \ - -start -41 -extent 85 - - set xy [box 346 339 15] ;# Center of rotor - $w.c create oval $xy -outline $::C(fg) -fill $::C(fg) -tag I6m - set xy {352 312 352 254 368 254 368 322} ;# Top drop to rotor - $w.c create poly $xy -fill $color -outline {} - $w.c create line $xy -fill $::C(fg) -width 2 - - set xy {353 240 367 300} ;# Poke bottom hole - $w.c create rect $xy -fill $color -outline {} - set xy {341 190 375 210} ;# Poke another hole - $w.c create rect $xy -fill $color -outline {} - - set xy {368 356 368 403 389 403 389 464 320 464 320 403 352 403 352 366} - $w.c create poly $xy -fill $color -outline {} -width 2 ;# Below rotor - $w.c create line $xy -fill $::C(fg) -width 2 - set xy [box 275 342 7] ;# On/off rotor - $w.c create oval $xy -outline $::C(fg) -fill $::C(fg) - set xy {276 334 342 325} ;# Fan belt top - $w.c create line $xy -fill $::C(fg) -width 3 - set xy {276 349 342 353} ;# Fan belt bottom - $w.c create line $xy -fill $::C(fg) -width 3 - - set xy {337 212 337 247} ;# What the mouse pushes - $w.c create line $xy -fill $::C(fg) -width 3 -tag I6_ - set xy {392 212 392 247} - $w.c create line $xy -fill $::C(fg) -width 3 -tag I6_ - set xy {337 230 392 230} - $w.c create line $xy -fill $::C(fg) -width 7 -tag I6_ - - set who -1 ;# All the balls - set colors {red cyan orange green blue darkblue} - lappend colors {*}$colors {*}$colors - - for {set i 0} {$i < 17} {incr i} { - set loc [expr {-1 * $i}] - set color [lindex $colors $i] - $w.c create oval [box {*}$::XY6($loc) 5] -fill $color \ - -outline $color -tag I6_b$i - } - Draw6a $w 12 ;# The wheel -} -proc Draw6a {w beta} { - $w.c delete I6_0 - lassign {346 339} Ox Oy - for {set i 0} {$i < 4} {incr i} { - set b [expr {$beta + $i * 45}] - lassign [RotateC 28 0 0 0 $b] x y - set xy [list [expr {$Ox+$x}] [expr {$Oy+$y}] \ - [expr {$Ox-$x}] [expr {$Oy-$y}]] - $w.c create line $xy -tag I6_0 -fill $::C(fg) -width 2 - } -} -proc Move6 {w {step {}}} { - set step [GetStep 6 $step] - if {$step > 62} { - return 0 - } - - if {$step < 2} { ;# Open gate for balls to drop - $w.c move I6_ -7 0 - if {$step == 1} { ;# Poke a hole - set xy {348 226 365 240} - $w.c create rect $xy -fill [$w.c itemcget I6c -fill] -outline {} - } - return 1 - } - - set s [expr {$step - 1}] ;# Do the gumball drop dance - for {set i 0} {$i <= int(($s-1) / 3)} {incr i} { - set tag "I6_b$i" - if {[$w.c find withtag $tag] eq ""} break - set loc [expr {$s - 3 * $i}] - - if {[info exists ::XY6($loc,$i)]} { - MoveAbs $w $tag $::XY6($loc,$i) - } elseif {[info exists ::XY6($loc)]} { - MoveAbs $w $tag $::XY6($loc) - } - } - if {($s % 3) == 1} { - set first [expr {($s + 2) / 3}] - for {set i $first} {1} {incr i} { - set tag "I6_b$i" - if {[$w.c find withtag $tag] eq ""} break - set loc [expr {$first - $i}] - MoveAbs $w $tag $::XY6($loc) - } - } - if {$s >= 3} { ;# Rotate the motor - set idx [expr {$s % 3}] - #Draw6a $w [lindex {12 35 64} $idx] - Draw6a $w [expr {12 + $s * 15}] - } - return [expr {$s == 3 ? 3 : 1}] -} - -# On/off switch -proc Draw7 {w} { - set color $::C(7) - set xy {198 306 277 374} ;# Box - $w.c create rect $xy -outline $::C(fg) -width 2 -fill $color -tag I7z - $w.c lower I7z - set xy {275 343 230 349} - $w.c create line $xy -tag I7 -fill $::C(fg) -arrow last \ - -arrowshape {23 23 8} -width 6 - set xy {225 324} ;# On button - $w.c create oval [box {*}$xy 3] -fill $::C(fg) -outline $::C(fg) - set xy {218 323} ;# On text - set font {{Times Roman} 8} - $w.c create text $xy -text "on" -anchor e -fill $::C(fg) -font $font - set xy {225 350} ;# Off button - $w.c create oval [box {*}$xy 3] -fill $::C(fg) -outline $::C(fg) - set xy {218 349} ;# Off button - $w.c create text $xy -text "off" -anchor e -fill $::C(fg) -font $font -} -proc Move7 {w {step {}}} { - set step [GetStep 7 $step] - set numsteps 30 - if {$step > $numsteps} { - return 0 - } - set beta [expr {30.0 / $numsteps}] - RotateItem $w I7 275 343 $beta - - return [expr {$step == $numsteps ? 3 : 1}] -} - -# Electricity to the fan -proc Draw8 {w} { - Sine $w 271 248 271 306 5 8 -tag I8_s -fill $::C(8) -width 3 -} -proc Move8 {w {step {}}} { - set step [GetStep 8 $step] - - if {$step > 3} { - return 0 - } - if {$step == 0} { - Sparkle $w [Anchor $w I8_s s] I8 - return 1 - - } elseif {$step == 1} { - MoveAbs $w I8 [Anchor $w I8_s c] - } elseif {$step == 2} { - MoveAbs $w I8 [Anchor $w I8_s n] - } else { - $w.c delete I8 - } - return [expr {$step == 2 ? 3 : 1}] -} - -# Fan -proc Draw9 {w} { - set color $::C(9) - set xy {266 194 310 220} - $w.c create oval $xy -outline $color -fill $color - set xy {280 209 296 248} - $w.c create oval $xy -outline $color -fill $color - set xy {288 249 252 249 260 240 280 234 296 234 316 240 324 249 288 249} - $w.c create poly $xy -fill $color -smooth 1 - - set xy {248 205 265 214 264 205 265 196} ;# Spinner - $w.c create poly $xy -fill $color - - set xy {255 206 265 234} ;# Fan blades - $w.c create oval $xy -fill {} -outline $::C(fg) -width 3 -tag I9_0 - set xy {255 176 265 204} - $w.c create oval $xy -fill {} -outline $::C(fg) -width 3 -tag I9_0 - set xy {255 206 265 220} - $w.c create oval $xy -fill {} -outline $::C(fg) -width 1 -tag I9_1 - set xy {255 190 265 204} - $w.c create oval $xy -fill {} -outline $::C(fg) -width 1 -tag I9_1 -} -proc Move9 {w {step {}}} { - set step [GetStep 9 $step] - - if {$step & 1} { - $w.c itemconfig I9_0 -width 4 - $w.c itemconfig I9_1 -width 1 - $w.c lower I9_1 I9_0 - } else { - $w.c itemconfig I9_0 -width 1 - $w.c itemconfig I9_1 -width 4 - $w.c lower I9_0 I9_1 - } - if {$step == 0} { - return 3 - } - return 1 -} - -# Boat -proc Draw10 {w} { - set color $::C(10a) - set color2 $::C(10b) - set xy {191 230 233 230 233 178 191 178} ;# Sail - $w.c create poly $xy -fill $color -width 3 -outline $::C(fg) -tag I10 - set xy [box 209 204 31] ;# Front - $w.c create arc $xy -outline {} -fill $color -style pie \ - -start 120 -extent 120 -tag I10 - $w.c create arc $xy -outline $::C(fg) -width 3 -style arc \ - -start 120 -extent 120 -tag I10 - set xy [box 249 204 31] ;# Back - $w.c create arc $xy -outline {} -fill $::C(bg) -width 3 -style pie \ - -start 120 -extent 120 -tag I10 - $w.c create arc $xy -outline $::C(fg) -width 3 -style arc \ - -start 120 -extent 120 -tag I10 - - set xy {200 171 200 249} ;# Mast - $w.c create line $xy -fill $::C(fg) -width 3 -tag I10 - set xy {159 234 182 234} ;# Bow sprit - $w.c create line $xy -fill $::C(fg) -width 3 -tag I10 - set xy {180 234 180 251 220 251} ;# Hull - $w.c create line $xy -fill $::C(fg) -width 6 -tag I10 - - set xy {92 255 221 255} ;# Waves - Sine $w {*}$xy 2 25 -fill $color2 -width 1 -tag I10w - - set xy [lrange [$w.c coords I10w] 4 end-4] ;# Water - set xy [concat $xy 222 266 222 277 99 277] - $w.c create poly $xy -fill $color2 -outline $color2 - set xy {222 266 222 277 97 277 97 266} ;# Water bottom - $w.c create line $xy -fill $::C(fg) -width 3 - - set xy [box 239 262 17] - $w.c create arc $xy -outline $::C(fg) -width 3 -style arc \ - -start 95 -extent 103 - set xy [box 76 266 21] - $w.c create arc $xy -outline $::C(fg) -width 3 -style arc -extent 190 -} -proc Move10 {w {step {}}} { - set step [GetStep 10 $step] - set pos { - {195 212} {193 212} {190 212} {186 212} {181 212} {176 212} - {171 212} {166 212} {161 212} {156 212} {151 212} {147 212} {142 212} - {137 212} {132 212 x} {127 212} {121 212} {116 212} {111 212} - } - - if {$step >= [llength $pos]} { - return 0 - } - set where [lindex $pos $step] - MoveAbs $w I10 $where - - if {[lindex $where 2] eq "x"} { - return 3 - } - return 1 -} - -# 2nd ball drop -proc Draw11 {w} { - set color $::C(11a) - set color2 $::C(11b) - set xy {23 264 55 591} ;# Color the down tube - $w.c create rect $xy -fill $color -outline {} - set xy [box 71 460 48] ;# Color the outer loop - $w.c create oval $xy -fill $color -outline {} - - set xy {55 264 55 458} ;# Top right side - $w.c create line $xy -fill $::C(fg) -width 3 - set xy {55 504 55 591} ;# Bottom right side - $w.c create line $xy -fill $::C(fg) -width 3 - set xy [box 71 460 48] ;# Outer loop - $w.c create arc $xy -outline $::C(fg) -width 3 -style arc \ - -start 110 -extent -290 -tag I11i - set xy [box 71 460 16] ;# Inner loop - $w.c create oval $xy -outline $::C(fg) -fill {} -width 3 -tag I11i - $w.c create oval $xy -outline $::C(fg) -fill $::C(bg) -width 3 - - set xy {23 264 23 591} ;# Left side - $w.c create line $xy -fill $::C(fg) -width 3 - set xy [box 1 266 23] ;# Top left curve - $w.c create arc $xy -outline $::C(fg) -width 3 -style arc -extent 90 - - set xy [box 75 235 9] ;# The ball - $w.c create oval $xy -fill $color2 -outline {} -width 3 -tag I11 -} -proc Move11 {w {step {}}} { - set step [GetStep 11 $step] - set pos { - {75 235} {70 235} {65 237} {56 240} {46 247} {38 266} {38 296} - {38 333} {38 399} {38 475} {74 496} {105 472} {100 437} {65 423} - {-100 -100} {38 505} {38 527 x} {38 591} - } - - if {$step >= [llength $pos]} { - return 0 - } - set where [lindex $pos $step] - MoveAbs $w I11 $where - if {[lindex $where 2] eq "x"} { - return 3 - } - return 1 -} - -# Hand -proc Draw12 {w} { - set xy {20 637 20 617 20 610 20 590 40 590 40 590 60 590 60 610 60 610} - lappend xy 60 610 65 620 60 631 ;# Thumb - lappend xy 60 631 60 637 60 662 60 669 52 669 56 669 50 669 50 662 50 637 - - set y0 637 ;# Bumps for fingers - set y1 645 - for {set x 50} {$x > 20} {incr x -10} { - set x1 [expr {$x - 5}] - set x2 [expr {$x - 10}] - lappend xy $x $y0 $x1 $y1 $x2 $y0 - } - $w.c create poly $xy -fill $::C(12) -outline $::C(fg) -smooth 1 -tag I12 \ - -width 3 -} -proc Move12 {w {step {}}} { - set step [GetStep 12 $step] - set pos {{42.5 641 x}} - if {$step >= [llength $pos]} { - return 0 - } - - set where [lindex $pos $step] - MoveAbs $w I12 $where - if {[lindex $where 2] eq "x"} { - return 3 - } - return 1 -} - -# Fax -proc Draw13 {w} { - set color $::C(13a) - set xy {86 663 149 663 149 704 50 704 50 681 64 681 86 671} - set xy2 {784 663 721 663 721 704 820 704 820 681 806 681 784 671} - set radii {2 9 9 8 5 5 2} - - RoundPoly $w.c $xy $radii -width 3 -outline $::C(fg) -fill $color - RoundPoly $w.c $xy2 $radii -width 3 -outline $::C(fg) -fill $color - - set xy {56 677} - $w.c create rect [box {*}$xy 4] -fill {} -outline $::C(fg) -width 3 \ - -tag I13 - set xy {809 677} - $w.c create rect [box {*}$xy 4] -fill {} -outline $::C(fg) -width 3 \ - -tag I13R - - set xy {112 687} ;# Label - $w.c create text $xy -text "FAX" -fill $::C(fg) \ - -font {{Times Roman} 12 bold} - set xy {762 687} - $w.c create text $xy -text "FAX" -fill $::C(fg) \ - -font {{Times Roman} 12 bold} - - set xy {138 663 148 636 178 636} ;# Paper guide - $w.c create line $xy -smooth 1 -fill $::C(fg) -width 3 - set xy {732 663 722 636 692 636} - $w.c create line $xy -smooth 1 -fill $::C(fg) -width 3 - - Sine $w 149 688 720 688 5 15 -tag I13_s -fill $::C(fg) -width 3 -} -proc Move13 {w {step {}}} { - set step [GetStep 13 $step] - set numsteps 7 - - if {$step == $numsteps+2} { - MoveAbs $w I13_star {-100 -100} - $w.c itemconfig I13R -fill $::C(13b) -width 2 - return 2 - } - if {$step == 0} { ;# Button down - $w.c delete I13 - Sparkle $w {-100 -100} I13_star ;# Create off screen - return 1 - } - lassign [Anchor $w I13_s w] x0 y0 - lassign [Anchor $w I13_s e] x1 y1 - set x [expr {$x0 + ($x1-$x0) * ($step - 1) / double($numsteps)}] - MoveAbs $w I13_star [list $x $y0] - return 1 -} - -# Paper in fax -proc Draw14 {w} { - set color $::C(14) - set xy {102 661 113 632 130 618} ;# Left paper edge - $w.c create line $xy -smooth 1 -fill $color -width 3 -tag I14L_0 - set xy {148 629 125 640 124 662} ;# Right paper edge - $w.c create line $xy -smooth 1 -fill $color -width 3 -tag I14L_1 - Draw14a $w L - - set xy { - 768.0 662.5 767.991316225 662.433786215 767.926187912 662.396880171 - } - $w.c create line $xy -smooth 1 -fill $color -width 3 -tag I14R_0 - $w.c lower I14R_0 - # NB. these numbers are VERY sensitive, you must start with final size - # and shrink down to get the values - set xy { - 745.947897349 662.428358855 745.997829056 662.452239237 746.0 662.5 - } - $w.c create line $xy -smooth 1 -fill $color -width 3 -tag I14R_1 - $w.c lower I14R_1 -} -proc Draw14a {w side} { - set color $::C(14) - set xy [$w.c coords I14${side}_0] - set xy2 [$w.c coords I14${side}_1] - lassign $xy x0 y0 x1 y1 x2 y2 - lassign $xy2 x3 y3 x4 y4 x5 y5 - set zz [concat \ - $x0 $y0 $x0 $y0 $xy $x2 $y2 $x2 $y2 \ - $x3 $y3 $x3 $y3 $xy2 $x5 $y5 $x5 $y5] - $w.c delete I14$side - $w.c create poly $zz -tag I14$side -smooth 1 -fill $color -outline $color \ - -width 3 - $w.c lower I14$side -} -proc Move14 {w {step {}}} { - set step [GetStep 14 $step] - - # Paper going down - set sc [expr {.9 - .05*$step}] - if {$sc < .3} { - $w.c delete I14L - return 0 - } - - lassign [$w.c coords I14L_0] Ox Oy - $w.c scale I14L_0 $Ox $Oy $sc $sc - lassign [lrange [$w.c coords I14L_1] end-1 end] Ox Oy - $w.c scale I14L_1 $Ox $Oy $sc $sc - Draw14a $w L - - # Paper going up - set sc [expr {.35 + .05*$step}] - set sc [expr {1 / $sc}] - - lassign [$w.c coords I14R_0] Ox Oy - $w.c scale I14R_0 $Ox $Oy $sc $sc - lassign [lrange [$w.c coords I14R_1] end-1 end] Ox Oy - $w.c scale I14R_1 $Ox $Oy $sc $sc - Draw14a $w R - - return [expr {$step == 10 ? 3 : 1}] -} - -# Light beam -proc Draw15 {w} { - set color $::C(15a) - set xy {824 599 824 585 820 585 829 585} - $w.c create line $xy -fill $::C(fg) -width 3 -tag I15a - set xy {789 599 836 643} - $w.c create rect $xy -fill $color -outline $::C(fg) -width 3 - set xy {778 610 788 632} - $w.c create rect $xy -fill $color -outline $::C(fg) -width 3 - set xy {766 617 776 625} - $w.c create rect $xy -fill $color -outline $::C(fg) -width 3 - - set xy {633 600 681 640} - $w.c create rect $xy -fill $color -outline $::C(fg) -width 3 - set xy {635 567 657 599} - $w.c create rect $xy -fill $color -outline $::C(fg) -width 2 - set xy {765 557 784 583} - $w.c create rect $xy -fill $color -outline $::C(fg) -width 2 - - Sine $w 658 580 765 580 3 15 -tag I15_s -fill $::C(fg) -width 3 -} -proc Move15a {w} { - set color $::C(15b) - $w.c scale I15a 824 599 1 .3 ;# Button down - set xy {765 621 681 621} - $w.c create line $xy -dash "-" -width 3 -fill $color -tag I15 -} -proc Move15 {w {step {}}} { - set step [GetStep 15 $step] - set numsteps 6 - - if {$step == $numsteps+2} { - MoveAbs $w I15_star {-100 -100} - return 2 - } - if {$step == 0} { ;# Break the light beam - Sparkle $w {-100 -100} I15_star - set xy {765 621 745 621} - $w.c coords I15 $xy - return 1 - } - lassign [Anchor $w I15_s w] x0 y0 - lassign [Anchor $w I15_s e] x1 y1 - set x [expr {$x0 + ($x1-$x0) * ($step - 1) / double($numsteps)}] - MoveAbs $w I15_star [list $x $y0] - return 1 -} - -# Bell -proc Draw16 {w} { - set color $::C(16) - set xy {722 485 791 556} - $w.c create rect $xy -fill {} -outline $::C(fg) -width 3 - set xy [box 752 515 25] ;# Bell - $w.c create oval $xy -fill $color -outline black -tag I16b -width 2 - set xy [box 752 515 5] ;# Bell button - $w.c create oval $xy -fill black -outline black -tag I16b - - set xy {784 523 764 549} ;# Clapper - $w.c create line $xy -width 3 -tag I16c -fill $::C(fg) - set xy [box 784 523 4] - $w.c create oval $xy -fill $::C(fg) -outline $::C(fg) -tag I16d -} -proc Move16 {w {step {}}} { - set step [GetStep 16 $step] - - # Note: we never stop - lassign {760 553} Ox Oy - if {$step & 1} { - set beta 12 - $w.c move I16b 3 0 - } else { - set beta -12 - $w.c move I16b -3 0 - } - RotateItem $w I16c $Ox $Oy $beta - RotateItem $w I16d $Ox $Oy $beta - - return [expr {$step == 1 ? 3 : 1}] -} - -# Cat -proc Draw17 {w} { - set color $::C(17) - - set xy {584 556 722 556} - $w.c create line $xy -fill $::C(fg) -width 3 - set xy {584 485 722 485} - $w.c create line $xy -fill $::C(fg) -width 3 - - set xy {664 523 717 549} ;# Body - $w.c create arc $xy -outline $::C(fg) -fill $color -width 3 \ - -style chord -start 128 -extent -260 -tag I17 - - set xy {709 554 690 543} ;# Paw - $w.c create oval $xy -outline $::C(fg) -fill $color -width 3 -tag I17 - set xy {657 544 676 555} - $w.c create oval $xy -outline $::C(fg) -fill $color -width 3 -tag I17 - - set xy [box 660 535 15] ;# Lower face - $w.c create arc $xy -outline $::C(fg) -width 3 -style arc \ - -start 150 -extent 240 -tag I17_ - $w.c create arc $xy -outline {} -fill $color -width 1 -style chord \ - -start 150 -extent 240 -tag I17_ - set xy {674 529 670 513 662 521 658 521 650 513 647 529} ;# Ears - $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_ - $w.c create poly $xy -fill $color -outline {} -width 1 -tag {I17_ I17_c} - set xy {652 542 628 539} ;# Whiskers - $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_ - set xy {652 543 632 545} - $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_ - set xy {652 546 632 552} - $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_ - - set xy {668 543 687 538} - $w.c create line $xy -fill $::C(fg) -width 3 -tag {I17_ I17w} - set xy {668 544 688 546} - $w.c create line $xy -fill $::C(fg) -width 3 -tag {I17_ I17w} - set xy {668 547 688 553} - $w.c create line $xy -fill $::C(fg) -width 3 -tag {I17_ I17w} - - set xy {649 530 654 538 659 530} ;# Left eye - $w.c create line $xy -fill $::C(fg) -width 2 -smooth 1 -tag I17 - set xy {671 530 666 538 661 530} ;# Right eye - $w.c create line $xy -fill $::C(fg) -width 2 -smooth 1 -tag I17 - set xy {655 543 660 551 665 543} ;# Mouth - $w.c create line $xy -fill $::C(fg) -width 2 -smooth 1 -tag I17 -} -proc Move17 {w {step {}}} { - set step [GetStep 17 $step] - - if {$step == 0} { - $w.c delete I17 ;# Delete most of the cat - set xy {655 543 660 535 665 543} ;# Mouth - $w.c create line $xy -fill $::C(fg) -width 3 -smooth 1 -tag I17_ - set xy [box 654 530 4] ;# Left eye - $w.c create oval $xy -outline $::C(fg) -width 3 -fill {} -tag I17_ - set xy [box 666 530 4] ;# Right eye - $w.c create oval $xy -outline $::C(fg) -width 3 -fill {} -tag I17_ - - $w.c move I17_ 0 -20 ;# Move face up - set xy {652 528 652 554} ;# Front leg - $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_ - set xy {670 528 670 554} ;# 2nd front leg - $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_ - - set xy { - 675 506 694 489 715 513 715 513 715 513 716 525 716 525 716 525 - 706 530 695 530 679 535 668 527 668 527 668 527 675 522 676 517 - 677 512 - } ;# Body - $w.c create poly $xy -fill [$w.c itemcget I17_c -fill] \ - -outline $::C(fg) -width 3 -smooth 1 -tag I17_ - set xy {716 514 716 554} ;# Back leg - $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_ - set xy {694 532 694 554} ;# 2nd back leg - $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_ - set xy {715 514 718 506 719 495 716 488};# Tail - $w.c create line $xy -fill $::C(fg) -width 3 -smooth 1 -tag I17_ - - $w.c raise I17w ;# Make whiskers visible - $w.c move I17_ -5 0 ;# Move away from wall a bit - return 2 - } - return 0 -} - -# Sling shot -proc Draw18 {w} { - set color $::C(18) - set xy {721 506 627 506} ;# Sling hold - $w.c create line $xy -width 4 -fill $::C(fg) -tag I18 - - set xy {607 500 628 513} ;# Sling rock - $w.c create oval $xy -fill $color -outline {} -tag I18a - - set xy {526 513 606 507 494 502} ;# Sling band - $w.c create line $xy -fill $::C(fg) -width 4 -tag I18b - set xy { 485 490 510 540 510 575 510 540 535 491 } ;# Sling - $w.c create line $xy -fill $::C(fg) -width 6 -} -proc Move18 {w {step {}}} { - set step [GetStep 18 $step] - - set pos { - {587 506} {537 506} {466 506} {376 506} {266 506 x} {136 506} - {16 506} {-100 -100} - } - - set b(0) {490 502 719 507 524 512} ;# Band collapsing - set b(1) { - 491 503 524 557 563 505 559 496 546 506 551 525 553 536 538 534 - 532 519 529 499 - } - set b(2) {491 503 508 563 542 533 551 526 561 539 549 550 530 500} - set b(3) {491 503 508 563 530 554 541 562 525 568 519 544 530 501} - - if {$step >= [llength $pos]} { - return 0 - } - - if {$step == 0} { - $w.c delete I18 - $w.c itemconfig I18b -smooth 1 - } - if {[info exists b($step)]} { - $w.c coords I18b $b($step) - } - - set where [lindex $pos $step] - MoveAbs $w I18a $where - if {[lindex $where 2] eq "x"} { - return 3 - } - return 1 -} - -# Water pipe -proc Draw19 {w} { - set color $::C(19) - set xx {249 181 155 118 86 55 22 0} - foreach {x1 x2} $xx { - $w.c create rect $x1 453 $x2 467 -fill $color -outline {} -tag I19 - $w.c create line $x1 453 $x2 453 -fill $::C(fg) -width 1;# Pipe top - $w.c create line $x1 467 $x2 467 -fill $::C(fg) -width 1;# Pipe bottom - } - $w.c raise I11i - - set xy [box 168 460 16] ;# Bulge by the joint - $w.c create oval $xy -fill $color -outline {} - $w.c create arc $xy -outline $::C(fg) -width 1 -style arc \ - -start 21 -extent 136 - $w.c create arc $xy -outline $::C(fg) -width 1 -style arc \ - -start -21 -extent -130 - - set xy {249 447 255 473} ;# First joint 26x6 - $w.c create rect $xy -fill $color -outline $::C(fg) -width 1 - - set xy [box 257 433 34] ;# Bend up - $w.c create arc $xy -outline {} -fill $color -width 1 \ - -style pie -start 0 -extent -91 - $w.c create arc $xy -outline $::C(fg) -width 1 \ - -style arc -start 0 -extent -90 - set xy [box 257 433 20] - $w.c create arc $xy -outline {} -fill $::C(bg) -width 1 \ - -style pie -start 0 -extent -92 - $w.c create arc $xy -outline $::C(fg) -width 1 \ - -style arc -start 0 -extent -90 - set xy [box 257 421 34] ;# Bend left - $w.c create arc $xy -outline {} -fill $color -width 1 \ - -style pie -start 1 -extent 91 - $w.c create arc $xy -outline $::C(fg) -width 1 \ - -style arc -start 0 -extent 90 - set xy [box 257 421 20] - $w.c create arc $xy -outline {} -fill $::C(bg) -width 1 \ - -style pie -start 0 -extent 90 - $w.c create arc $xy -outline $::C(fg) -width 1 \ - -style arc -start 0 -extent 90 - set xy [box 243 421 34] ;# Bend down - $w.c create arc $xy -outline {} -fill $color -width 1 \ - -style pie -start 90 -extent 90 - $w.c create arc $xy -outline $::C(fg) -width 1 \ - -style arc -start 90 -extent 90 - set xy [box 243 421 20] - $w.c create arc $xy -outline {} -fill $::C(bg) -width 1 \ - -style pie -start 90 -extent 90 - $w.c create arc $xy -outline $::C(fg) -width 1 \ - -style arc -start 90 -extent 90 - - set xy {270 427 296 433} ;# 2nd joint bottom - $w.c create rect $xy -fill $color -outline $::C(fg) -width 1 - set xy {270 421 296 427} ;# 2nd joint top - $w.c create rect $xy -fill $color -outline $::C(fg) -width 1 - set xy {249 382 255 408} ;# Third joint right - $w.c create rect $xy -fill $color -outline $::C(fg) -width 1 - set xy {243 382 249 408} ;# Third joint left - $w.c create rect $xy -fill $color -outline $::C(fg) -width 1 - set xy {203 420 229 426} ;# Last joint - $w.c create rect $xy -fill $color -outline $::C(fg) -width 1 - - set xy [box 168 460 6] ;# Handle joint - $w.c create oval $xy -fill $::C(fg) -outline {} -tag I19a - set xy {168 460 168 512} ;# Handle bar - $w.c create line $xy -fill $::C(fg) -width 5 -tag I19b -} -proc Move19 {w {step {}}} { - set step [GetStep 19 $step] - - set angles {30 30 30} - if {$step == [llength $angles]} { - return 2 - } - - RotateItem $w I19b {*}[Centroid $w I19a] [lindex $angles $step] - return 1 -} - -# Water pouring -proc Draw20 {w} { -} -proc Move20 {w {step {}}} { - set step [GetStep 20 $step] - - set pos {451 462 473 484 496 504 513 523 532} - set freq {20 40 40 40 40 40 40 40 40} - set pos { - {451 20} {462 40} {473 40} {484 40} {496 40} {504 40} {513 40} - {523 40} {532 40 x} - } - if {$step >= [llength $pos]} { - return 0 - } - - $w.c delete I20 - set where [lindex $pos $step] - lassign $where y f - H2O $w $y $f - if {[lindex $where 2] eq "x"} { - return 3 - } - return 1 -} -proc H2O {w y f} { - set color $::C(20) - $w.c delete I20 - - Sine $w 208 428 208 $y 4 $f -tag {I20 I20s} -width 3 -fill $color \ - -smooth 1 - $w.c create line [$w.c coords I20s] -width 3 -fill $color -smooth 1 \ - -tag {I20 I20a} - $w.c create line [$w.c coords I20s] -width 3 -fill $color -smooth 1 \ - -tag {I20 I20b} - $w.c move I20a 8 0 - $w.c move I20b 16 0 -} - -# Bucket -proc Draw21 {w} { - set color $::C(21) - set xy {217 451 244 490} ;# Right handle - $w.c create line $xy -fill $::C(fg) -width 2 -tag I21_a - set xy {201 467 182 490} ;# Left handle - $w.c create line $xy -fill $::C(fg) -width 2 -tag I21_a - - set xy {245 490 237 535} ;# Right side - set xy2 {189 535 181 490} ;# Left side - $w.c create poly [concat $xy $xy2] -fill $color -outline {} \ - -tag {I21 I21f} - $w.c create line $xy -fill $::C(fg) -width 2 -tag I21 - $w.c create line $xy2 -fill $::C(fg) -width 2 -tag I21 - - set xy {182 486 244 498} ;# Top - $w.c create oval $xy -fill $color -outline {} -width 2 -tag {I21 I21f} - $w.c create oval $xy -fill {} -outline $::C(fg) -width 2 -tag {I21 I21t} - set xy {189 532 237 540} ;# Bottom - $w.c create oval $xy -fill $color -outline $::C(fg) -width 2 \ - -tag {I21 I21b} -} -proc Move21 {w {step {}}} { - set step [GetStep 21 $step] - - set numsteps 30 - if {$step >= $numsteps} { - return 0 - } - - lassign [$w.c coords I21b] x1 y1 x2 y2 - #lassign [$w.c coords I21t] X1 Y1 X2 Y2 - lassign {183 492 243 504} X1 Y1 X2 Y2 - - set f [expr {$step / double($numsteps)}] - set y2 [expr {$y2 - 3}] - set xx1 [expr {$x1 + ($X1 - $x1) * $f}] - set yy1 [expr {$y1 + ($Y1 - $y1) * $f}] - set xx2 [expr {$x2 + ($X2 - $x2) * $f}] - set yy2 [expr {$y2 + ($Y2 - $y2) * $f}] - #H2O $w $yy1 40 - - $w.c itemconfig I21b -fill $::C(20) - $w.c delete I21w - $w.c create poly $x2 $y2 $x1 $y1 $xx1 $yy1 $xx2 $yy1 -tag {I21 I21w} \ - -outline {} -fill $::C(20) - $w.c lower I21w I21 - $w.c raise I21b - $w.c lower I21f - - return [expr {$step == $numsteps-1 ? 3 : 1}] -} - -# Bucket drop -proc Draw22 {w} { -} -proc Move22 {w {step {}}} { - set step [GetStep 22 $step] - set pos {{213 513} {213 523} {213 543 x} {213 583} {213 593}} - - if {$step == 0} {$w.c itemconfig I21f -fill $::C(22)} - if {$step >= [llength $pos]} { - return 0 - } - set where [lindex $pos $step] - MoveAbs $w I21 $where - H2O $w [lindex $where 1] 40 - $w.c delete I21_a ;# Delete handles - - if {[lindex $where 2] eq "x"} { - return 3 - } - return 1 -} - -# Blow dart -proc Draw23 {w} { - set color $::C(23a) - set color2 $::C(23b) - set color3 $::C(23c) - - set xy {185 623 253 650} ;# Block - $w.c create rect $xy -fill black -outline $::C(fg) -width 2 -tag I23a - set xy {187 592 241 623} ;# Balloon - $w.c create oval $xy -outline {} -fill $color -tag I23b - $w.c create arc $xy -outline $::C(fg) -width 3 -tag I23b \ - -style arc -start 12 -extent 336 - set xy {239 604 258 589 258 625 239 610} ;# Balloon nozzle - $w.c create poly $xy -outline {} -fill $color -tag I23b - $w.c create line $xy -fill $::C(fg) -width 3 -tag I23b - - set xy {285 611 250 603} ;# Dart body - $w.c create oval $xy -fill $color2 -outline $::C(fg) -width 3 -tag I23d - set xy {249 596 249 618 264 607 249 596} ;# Dart tail - $w.c create poly $xy -fill $color3 -outline $::C(fg) -width 3 -tag I23d - set xy {249 607 268 607} ;# Dart detail - $w.c create line $xy -fill $::C(fg) -width 3 -tag I23d - set xy {285 607 305 607} ;# Dart needle - $w.c create line $xy -fill $::C(fg) -width 3 -tag I23d -} -proc Move23 {w {step {}}} { - set step [GetStep 23 $step] - - set pos { - {277 607} {287 607} {307 607 x} {347 607} {407 607} {487 607} - {587 607} {687 607} {787 607} {-100 -100} - } - - if {$step >= [llength $pos]} { - return 0 - } - if {$step <= 1} { - $w.c scale I23b {*}[Anchor $w I23a n] .9 .5 - } - set where [lindex $pos $step] - MoveAbs $w I23d $where - - if {[lindex $where 2] eq "x"} { - return 3 - } - return 1 -} - -# Balloon -proc Draw24 {w} { - set color $::C(24a) - set xy {366 518 462 665} ;# Balloon - $w.c create oval $xy -fill $color -outline $::C(fg) -width 3 -tag I24 - set xy {414 666 414 729} ;# String - $w.c create line $xy -fill $::C(fg) -width 3 -tag I24 - set xy {410 666 404 673 422 673 418 666} ;# Nozzle - $w.c create poly $xy -fill $color -outline $::C(fg) -width 3 -tag I24 - - set xy {387 567 390 549 404 542} ;# Reflections - $w.c create line $xy -fill $::C(fg) -smooth 1 -width 2 -tag I24 - set xy {395 568 399 554 413 547} - $w.c create line $xy -fill $::C(fg) -smooth 1 -width 2 -tag I24 - set xy {403 570 396 555 381 553} - $w.c create line $xy -fill $::C(fg) -smooth 1 -width 2 -tag I24 - set xy {408 564 402 547 386 545} - $w.c create line $xy -fill $::C(fg) -smooth 1 -width 2 -tag I24 -} -proc Move24 {w {step {}}} { - global S - set step [GetStep 24 $step] - - if {$step > 4} { - return 0 - } elseif {$step == 4} { - return 2 - } - - if {$step == 0} { - $w.c delete I24 ;# Exploding balloon - set xy { - 347 465 361 557 271 503 272 503 342 574 259 594 259 593 362 626 - 320 737 320 740 398 691 436 738 436 739 476 679 528 701 527 702 - 494 627 548 613 548 613 480 574 577 473 577 473 474 538 445 508 - 431 441 431 440 400 502 347 465 347 465 - } - $w.c create poly $xy -tag I24 -fill $::C(24b) -outline $::C(24a) \ - -width 10 -smooth 1 - set msg [subst $S(message)] - $w.c create text [Centroid $w I24] -text $msg -tag {I24 I24t} \ - -justify center -font {{Times Roman} 18 bold} - return 1 - } - - $w.c itemconfig I24t -font [list {Times Roman} [expr {18 + 6*$step}] bold] - $w.c move I24 0 -60 - $w.c scale I24 {*}[Centroid $w I24] 1.25 1.25 - return 1 -} - -# Displaying the message -proc Move25 {w {step {}}} { - global S - set step [GetStep 25 $step] - if {$step == 0} { - set ::XY(25) [clock clicks -milliseconds] - return 1 - } - set elapsed [expr {[clock clicks -milliseconds] - $::XY(25)}] - if {$elapsed < 5000} { - return 1 - } - return 2 -} - -# Collapsing balloon -proc Move26 {w {step {}}} { - global S - set step [GetStep 26 $step] - - if {$step >= 3} { - $w.c delete I24 I26 - $w.c create text 430 755 -anchor s -tag I26 \ - -text "click to continue" -font {{Times Roman} 24 bold} - bind $w.c <1> [list Reset $w] - return 4 - } - - $w.c scale I24 {*}[Centroid $w I24] .8 .8 - $w.c move I24 0 60 - $w.c itemconfig I24t -font [list {Times Roman} [expr {30 - 6*$step}] bold] - return 1 -} - -################################################################ -# -# Helper functions -# - -proc box {x y r} { - return [list [expr {$x-$r}] [expr {$y-$r}] [expr {$x+$r}] [expr {$y+$r}]] -} - -proc MoveAbs {w item xy} { - lassign $xy x y - lassign [Centroid $w $item] Ox Oy - set dx [expr {$x - $Ox}] - set dy [expr {$y - $Oy}] - $w.c move $item $dx $dy -} - -proc RotateItem {w item Ox Oy beta} { - set xy [$w.c coords $item] - set xy2 {} - foreach {x y} $xy { - lappend xy2 {*}[RotateC $x $y $Ox $Oy $beta] - } - $w.c coords $item $xy2 -} - -proc RotateC {x y Ox Oy beta} { - # rotates vector (Ox,Oy)->(x,y) by beta degrees clockwise - - set x [expr {$x - $Ox}] ;# Shift to origin - set y [expr {$y - $Oy}] - - set beta [expr {$beta * atan(1) * 4 / 180.0}] ;# Radians - set xx [expr {$x * cos($beta) - $y * sin($beta)}] ;# Rotate - set yy [expr {$x * sin($beta) + $y * cos($beta)}] - - set xx [expr {$xx + $Ox}] ;# Shift back - set yy [expr {$yy + $Oy}] - - return [list $xx $yy] -} - -proc Reset {w} { - global S - DrawAll $w - bind $w.c <1> {} - set S(mode) $::MSTART - set S(active) 0 -} - -# Each Move## keeps its state info in STEP, this retrieves and increments it -proc GetStep {who step} { - global STEP - if {$step ne ""} { - set STEP($who) $step - } elseif {![info exists STEP($who)] || $STEP($who) eq ""} { - set STEP($who) 0 - } else { - incr STEP($who) - } - return $STEP($who) -} - -proc ResetStep {} { - global STEP - set ::S(cnt) 0 - foreach a [array names STEP] { - set STEP($a) "" - } -} - -proc Sine {w x0 y0 x1 y1 amp freq args} { - set PI [expr {4 * atan(1)}] - set step 2 - set xy {} - if {$y0 == $y1} { ;# Horizontal - for {set x $x0} {$x <= $x1} {incr x $step} { - set beta [expr {($x - $x0) * 2 * $PI / $freq}] - set y [expr {$y0 + $amp * sin($beta)}] - lappend xy $x $y - } - } else { - for {set y $y0} {$y <= $y1} {incr y $step} { - set beta [expr {($y - $y0) * 2 * $PI / $freq}] - set x [expr {$x0 + $amp * sin($beta)}] - lappend xy $x $y - } - } - return [$w.c create line $xy {*}$args] -} - -proc RoundRect {w xy radius args} { - lassign $xy x0 y0 x3 y3 - set r [winfo pixels $w.c $radius] - set d [expr {2 * $r}] - - # Make sure that the radius of the curve is less than 3/8 size of the box! - set maxr 0.75 - if {$d > $maxr * ($x3 - $x0)} { - set d [expr {$maxr * ($x3 - $x0)}] - } - if {$d > $maxr * ($y3 - $y0)} { - set d [expr {$maxr * ($y3 - $y0)}] - } - - set x1 [expr { $x0 + $d }] - set x2 [expr { $x3 - $d }] - set y1 [expr { $y0 + $d }] - set y2 [expr { $y3 - $d }] - - set xy [list $x0 $y0 $x1 $y0 $x2 $y0 $x3 $y0 $x3 $y1 $x3 $y2] - lappend xy $x3 $y3 $x2 $y3 $x1 $y3 $x0 $y3 $x0 $y2 $x0 $y1 - return $xy -} - -proc RoundPoly {canv xy radii args} { - set lenXY [llength $xy] - set lenR [llength $radii] - if {$lenXY != 2*$lenR} { - error "wrong number of vertices and radii" - } - - set knots {} - lassign [lrange $xy end-1 end] x0 y0 - lassign $xy x1 y1 - lappend xy {*}[lrange $xy 0 1] - - for {set i 0} {$i < $lenXY} {incr i 2} { - set radius [lindex $radii [expr {$i/2}]] - set r [winfo pixels $canv $radius] - - lassign [lrange $xy [expr {$i + 2}] [expr {$i + 3}]] x2 y2 - set z [_RoundPoly2 $x0 $y0 $x1 $y1 $x2 $y2 $r] - lappend knots {*}$z - - lassign [list $x1 $y1] x0 y0 - lassign [list $x2 $y2] x1 y1 - } - set n [$canv create polygon $knots -smooth 1 {*}$args] - return $n -} - -proc _RoundPoly2 {x0 y0 x1 y1 x2 y2 radius} { - set d [expr {2 * $radius}] - set maxr 0.75 - - set v1x [expr {$x0 - $x1}] - set v1y [expr {$y0 - $y1}] - set v2x [expr {$x2 - $x1}] - set v2y [expr {$y2 - $y1}] - - set vlen1 [expr {sqrt($v1x*$v1x + $v1y*$v1y)}] - set vlen2 [expr {sqrt($v2x*$v2x + $v2y*$v2y)}] - if {$d > $maxr * $vlen1} { - set d [expr {$maxr * $vlen1}] - } - if {$d > $maxr * $vlen2} { - set d [expr {$maxr * $vlen2}] - } - - lappend xy [expr {$x1 + $d * $v1x/$vlen1}] [expr {$y1 + $d * $v1y/$vlen1}] - lappend xy $x1 $y1 - lappend xy [expr {$x1 + $d * $v2x/$vlen2}] [expr {$y1 + $d * $v2y/$vlen2}] - - return $xy -} - -proc Sparkle {w Oxy tag} { - set xy {299 283 298 302 295 314 271 331 239 310 242 292 256 274 281 273} - foreach {x y} $xy { - $w.c create line 271 304 $x $y -fill white -width 3 -tag $tag - } - MoveAbs $w $tag $Oxy -} - -proc Centroid {w item} { - return [Anchor $w $item c] -} - -proc Anchor {w item where} { - lassign [$w.c bbox $item] x1 y1 x2 y2 - if {[string match *n* $where]} { - set y $y1 - } elseif {[string match *s* $where]} { - set y $y2 - } else { - set y [expr {($y1 + $y2) / 2.0}] - } - if {[string match *w* $where]} { - set x $x1 - } elseif {[string match *e* $where]} { - set x $x2 - } else { - set x [expr {($x1 + $x2) / 2.0}] - } - return [list $x $y] -} - -DoDisplay $w -Reset $w -Go $w ;# Start everything going diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/hello b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/hello @@ -1,22 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish8.6 "$0" ${1+"$@"} - -# hello -- -# Simple Tk script to create a button that prints "Hello, world". -# Click on the button to terminate the program. - -package require Tk - -# The first line below creates the button, and the second line -# asks the packer to shrink-wrap the application's main window -# around the button. - -button .hello -text "Hello, world" -command { - puts stdout "Hello, world"; destroy . -} -pack .hello - -# Local Variables: -# mode: tcl -# End: diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/hscale.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/hscale.tcl @@ -1,45 +0,0 @@ -# hscale.tcl -- -# -# This demonstration script shows an example with a horizontal scale. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .hscale -catch {destroy $w} -toplevel $w -wm title $w "Horizontal Scale Demonstration" -wm iconname $w "hscale" -positionWindow $w - -label $w.msg -font $font -wraplength 3.5i -justify left -text "An arrow and a horizontal scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the length of the arrow." -pack $w.msg -side top -padx .5c - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -frame $w.frame -borderwidth 10 -pack $w.frame -side top -fill x - -canvas $w.frame.canvas -width 50 -height 50 -bd 0 -highlightthickness 0 -$w.frame.canvas create polygon 0 0 1 1 2 2 -fill DeepSkyBlue3 -tags poly -$w.frame.canvas create line 0 0 1 1 2 2 0 0 -fill black -tags line -scale $w.frame.scale -orient horizontal -length 284 -from 0 -to 250 \ - -command "setWidth $w.frame.canvas" -tickinterval 50 -pack $w.frame.canvas -side top -expand yes -anchor s -fill x -padx 15 -pack $w.frame.scale -side bottom -expand yes -anchor n -$w.frame.scale set 75 - -proc setWidth {w width} { - incr width 21 - set x2 [expr {$width - 30}] - if {$x2 < 21} { - set x2 21 - } - $w coords poly 20 15 20 35 $x2 35 $x2 45 $width 25 $x2 5 $x2 15 20 15 - $w coords line 20 15 20 35 $x2 35 $x2 45 $width 25 $x2 5 $x2 15 20 15 -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/icon.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/icon.tcl @@ -1,51 +0,0 @@ -# icon.tcl -- -# -# This demonstration script creates a toplevel window containing -# buttons that display bitmaps instead of text. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .icon -catch {destroy $w} -toplevel $w -wm title $w "Iconic Button Demonstration" -wm iconname $w "icon" -positionWindow $w - -label $w.msg -font $font -wraplength 5i -justify left -text "This window shows three ways of using bitmaps or images in radiobuttons and checkbuttons. On the left are two radiobuttons, each of which displays a bitmap and an indicator. In the middle is a checkbutton that displays a different image depending on whether it is selected or not. On the right is a checkbutton that displays a single bitmap but changes its background color to indicate whether or not it is selected." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -# Main widget program sets variable tk_demoDirectory -image create bitmap flagup \ - -file [file join $tk_demoDirectory images flagup.xbm] \ - -maskfile [file join $tk_demoDirectory images flagup.xbm] -image create bitmap flagdown \ - -file [file join $tk_demoDirectory images flagdown.xbm] \ - -maskfile [file join $tk_demoDirectory images flagdown.xbm] -frame $w.frame -borderwidth 10 -pack $w.frame -side top - -checkbutton $w.frame.b1 -image flagdown -selectimage flagup \ - -indicatoron 0 -$w.frame.b1 configure -selectcolor [$w.frame.b1 cget -background] -checkbutton $w.frame.b2 \ - -bitmap @[file join $tk_demoDirectory images letters.xbm] \ - -indicatoron 0 -selectcolor SeaGreen1 -frame $w.frame.left -pack $w.frame.left $w.frame.b1 $w.frame.b2 -side left -expand yes -padx 5m - -radiobutton $w.frame.left.b3 \ - -bitmap @[file join $tk_demoDirectory images letters.xbm] \ - -variable letters -value full -radiobutton $w.frame.left.b4 \ - -bitmap @[file join $tk_demoDirectory images noletter.xbm] \ - -variable letters -value empty -pack $w.frame.left.b3 $w.frame.left.b4 -side top -expand yes diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/image1.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/image1.tcl @@ -1,35 +0,0 @@ -# image1.tcl -- -# -# This demonstration script displays two image widgets. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .image1 -catch {destroy $w} -toplevel $w -wm title $w "Image Demonstration #1" -wm iconname $w "Image1" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration displays two images, each in a separate label widget." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -# Main widget program sets variable tk_demoDirectory -catch {image delete image1a} -image create photo image1a -file [file join $tk_demoDirectory images earth.gif] -label $w.l1 -image image1a -bd 1 -relief sunken - -catch {image delete image1b} -image create photo image1b \ - -file [file join $tk_demoDirectory images earthris.gif] -label $w.l2 -image image1b -bd 1 -relief sunken - -pack $w.l1 $w.l2 -side top -padx .5m -pady .5m diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/image2.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/image2.tcl @@ -1,108 +0,0 @@ -# image2.tcl -- -# -# This demonstration script creates a simple collection of widgets -# that allow you to select and view images in a Tk label. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -# loadDir -- -# This procedure reloads the directory listbox from the directory -# named in the demo's entry. -# -# Arguments: -# w - Name of the toplevel window of the demo. - -proc loadDir w { - global dirName - - $w.f.list delete 0 end - foreach i [lsort [glob -type f -directory $dirName *]] { - $w.f.list insert end [file tail $i] - } -} - -# selectAndLoadDir -- -# This procedure pops up a dialog to ask for a directory to load into -# the listobx and (if the user presses OK) reloads the directory -# listbox from the directory named in the demo's entry. -# -# Arguments: -# w - Name of the toplevel window of the demo. - -proc selectAndLoadDir w { - global dirName - set dir [tk_chooseDirectory -initialdir $dirName -parent $w -mustexist 1] - if {$dir ne ""} { - set dirName $dir - loadDir $w - } -} - -# loadImage -- -# Given the name of the toplevel window of the demo and the mouse -# position, extracts the directory entry under the mouse and loads -# that file into a photo image for display. -# -# Arguments: -# w - Name of the toplevel window of the demo. -# x, y- Mouse position within the listbox. - -proc loadImage {w x y} { - global dirName - - set file [file join $dirName [$w.f.list get @$x,$y]] - if {[catch { - image2a configure -file $file - }]} then { - # Mark the file as not loadable - $w.f.list itemconfigure @$x,$y -bg \#c00000 -selectbackground \#ff0000 - } -} - -set w .image2 -catch {destroy $w} -toplevel $w -wm title $w "Image Demonstration #2" -wm iconname $w "Image2" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration allows you to view images using a Tk \"photo\" image. First type a directory name in the listbox, then type Return to load the directory into the listbox. Then double-click on a file name in the listbox to see that image." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -frame $w.mid -pack $w.mid -fill both -expand 1 - -labelframe $w.dir -text "Directory:" -# Main widget program sets variable tk_demoDirectory -set dirName [file join $tk_demoDirectory images] -entry $w.dir.e -width 30 -textvariable dirName -button $w.dir.b -pady 0 -padx 2m -text "Select Dir." \ - -command "selectAndLoadDir $w" -bind $w.dir.e <Return> "loadDir $w" -pack $w.dir.e -side left -fill both -padx 2m -pady 2m -expand true -pack $w.dir.b -side left -fill y -padx {0 2m} -pady 2m -labelframe $w.f -text "File:" -padx 2m -pady 2m - -listbox $w.f.list -width 20 -height 10 -yscrollcommand "$w.f.scroll set" -ttk::scrollbar $w.f.scroll -command "$w.f.list yview" -pack $w.f.list $w.f.scroll -side left -fill y -expand 1 -$w.f.list insert 0 earth.gif earthris.gif teapot.ppm -bind $w.f.list <Double-1> "loadImage $w %x %y" - -catch {image delete image2a} -image create photo image2a -labelframe $w.image -text "Image:" -label $w.image.image -image image2a -pack $w.image.image -padx 2m -pady 2m - -grid $w.dir - -sticky ew -padx 1m -pady 1m -in $w.mid -grid $w.f $w.image -sticky nw -padx 1m -pady 1m -in $w.mid -grid columnconfigure $w.mid 1 -weight 1 diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/earth.gif b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/earth.gif Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/earthmenu.png b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/earthmenu.png Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/earthris.gif b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/earthris.gif Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/flagdown.xbm b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/flagdown.xbm @@ -1,27 +0,0 @@ -#define flagdown_width 48 -#define flagdown_height 48 -static char flagdown_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x1e, 0x00, 0x00, - 0x00, 0x00, 0x80, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xe0, 0xe1, 0x00, 0x00, - 0x00, 0x00, 0x70, 0x80, 0x01, 0x00, 0x00, 0x00, 0x18, 0x00, 0x03, 0x00, - 0x00, 0x00, 0x0c, 0x00, 0x03, 0x00, 0x00, 0x00, 0x06, 0x00, 0x06, 0x04, - 0x00, 0x00, 0x03, 0x00, 0x06, 0x06, 0x00, 0x80, 0x01, 0x00, 0x06, 0x07, - 0x00, 0xc0, 0x1f, 0x00, 0x87, 0x07, 0x00, 0xe0, 0x7f, 0x80, 0xc7, 0x07, - 0x00, 0x70, 0xe0, 0xc0, 0xe5, 0x07, 0x00, 0x38, 0x80, 0xe1, 0x74, 0x07, - 0x00, 0x18, 0x80, 0x71, 0x3c, 0x07, 0x00, 0x0c, 0x00, 0x3b, 0x1e, 0x03, - 0x00, 0x0c, 0x00, 0x1f, 0x0f, 0x00, 0x00, 0x86, 0x1f, 0x8e, 0x07, 0x00, - 0x00, 0x06, 0x06, 0xc6, 0x05, 0x00, 0x00, 0x06, 0x00, 0xc6, 0x05, 0x00, - 0x00, 0x06, 0x00, 0xc6, 0x04, 0x00, 0x00, 0x06, 0x00, 0x06, 0x04, 0x00, - 0x7f, 0x06, 0x00, 0x06, 0xe4, 0xff, 0x00, 0x06, 0x00, 0x06, 0x04, 0x00, - 0x00, 0x06, 0x00, 0x06, 0x04, 0x00, 0x00, 0x06, 0x00, 0x06, 0x06, 0x00, - 0x00, 0x06, 0x00, 0x06, 0x03, 0x00, 0x00, 0x06, 0x00, 0x86, 0x01, 0x00, - 0x00, 0x06, 0x00, 0xc6, 0x00, 0x00, 0x00, 0x06, 0x00, 0x66, 0x00, 0x00, - 0x00, 0x06, 0x00, 0x36, 0x00, 0x00, 0x00, 0x06, 0x00, 0x3e, 0x00, 0x00, - 0x00, 0xfe, 0xff, 0x2f, 0x00, 0x00, 0x00, 0xfc, 0xff, 0x27, 0x00, 0x00, - 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, - 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, - 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, - 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00, - 0xf7, 0xbf, 0x8e, 0xfc, 0xdf, 0xf8, 0x9d, 0xeb, 0x9b, 0x76, 0xd2, 0x7a, - 0x46, 0x30, 0xe2, 0x0f, 0xe1, 0x47, 0x55, 0x84, 0x48, 0x11, 0x84, 0x19}; diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/flagup.xbm b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/flagup.xbm @@ -1,27 +0,0 @@ -#define flagup_width 48 -#define flagup_height 48 -static char flagup_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x7f, 0x00, - 0x00, 0x00, 0x00, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xef, 0x6a, 0x00, - 0x00, 0x00, 0xc0, 0x7b, 0x75, 0x00, 0x00, 0x00, 0xe0, 0xe0, 0x6a, 0x00, - 0x00, 0x00, 0x30, 0x60, 0x75, 0x00, 0x00, 0x00, 0x18, 0xe0, 0x7f, 0x00, - 0x00, 0x00, 0x0c, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x06, 0xe0, 0x04, 0x00, - 0x00, 0x00, 0x03, 0xe0, 0x04, 0x00, 0x00, 0x80, 0x01, 0xe0, 0x06, 0x00, - 0x00, 0xc0, 0x1f, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x7f, 0xe0, 0x07, 0x00, - 0x00, 0x70, 0xe0, 0xe0, 0x05, 0x00, 0x00, 0x38, 0x80, 0xe1, 0x04, 0x00, - 0x00, 0x18, 0x80, 0xf1, 0x04, 0x00, 0x00, 0x0c, 0x00, 0xfb, 0x04, 0x00, - 0x00, 0x0c, 0x00, 0xff, 0x04, 0x00, 0x00, 0x86, 0x1f, 0xee, 0x04, 0x00, - 0x00, 0x06, 0x06, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0xe6, 0x04, 0x00, - 0x00, 0x06, 0x00, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0x66, 0x04, 0x00, - 0x7f, 0x56, 0x52, 0x06, 0xe4, 0xff, 0x00, 0x76, 0x55, 0x06, 0x04, 0x00, - 0x00, 0x56, 0x57, 0x06, 0x04, 0x00, 0x00, 0x56, 0x55, 0x06, 0x06, 0x00, - 0x00, 0x56, 0xd5, 0x06, 0x03, 0x00, 0x00, 0x06, 0x00, 0x86, 0x01, 0x00, - 0x54, 0x06, 0x00, 0xc6, 0x54, 0x55, 0xaa, 0x06, 0x00, 0x66, 0xaa, 0x2a, - 0x54, 0x06, 0x00, 0x36, 0x55, 0x55, 0xaa, 0x06, 0x00, 0xbe, 0xaa, 0x2a, - 0x54, 0xfe, 0xff, 0x6f, 0x55, 0x55, 0xaa, 0xfc, 0xff, 0xa7, 0xaa, 0x2a, - 0x54, 0x01, 0x88, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a, - 0x54, 0x55, 0x8d, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a, - 0x54, 0x55, 0x8d, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a, - 0x54, 0x55, 0x8d, 0x50, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa8, 0xaa, 0x2a, - 0x54, 0x55, 0x95, 0x54, 0x55, 0x55, 0xaa, 0xaa, 0xaa, 0xaa, 0xaa, 0x2a, - 0x54, 0x55, 0x55, 0x55, 0x55, 0x15, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/gray25.xbm b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/gray25.xbm @@ -1,6 +0,0 @@ -#define grey_width 16 -#define grey_height 16 -static char grey_bits[] = { - 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44, - 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44, - 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44}; diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/letters.xbm b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/letters.xbm @@ -1,27 +0,0 @@ -#define letters_width 48 -#define letters_height 48 -static char letters_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0xfe, 0xff, 0xff, 0xff, 0x3f, 0x00, 0x02, 0x00, 0x00, 0x00, 0x20, - 0x00, 0xfa, 0x00, 0x00, 0x00, 0x2e, 0x00, 0x02, 0x00, 0x00, 0x00, 0x2a, - 0x00, 0x3a, 0x00, 0x00, 0x00, 0x2a, 0x00, 0x02, 0x00, 0x00, 0x00, 0x2e, - 0xe0, 0xff, 0xff, 0xff, 0xff, 0x21, 0x20, 0x00, 0x00, 0x00, 0x00, 0x21, - 0xa0, 0x03, 0x00, 0x00, 0x70, 0x21, 0x20, 0x00, 0x00, 0x00, 0x50, 0x21, - 0xa0, 0x1f, 0x00, 0x00, 0x50, 0x21, 0x20, 0x00, 0x00, 0x00, 0x70, 0x21, - 0xfe, 0xff, 0xff, 0xff, 0x0f, 0x21, 0x02, 0x00, 0x00, 0x00, 0x08, 0x21, - 0xfa, 0x01, 0x00, 0x80, 0x0b, 0x21, 0x02, 0x00, 0x00, 0x80, 0x0a, 0x21, - 0xba, 0x01, 0x00, 0x80, 0x0a, 0x21, 0x02, 0x00, 0x00, 0x80, 0x0b, 0x21, - 0x3a, 0x00, 0x00, 0x00, 0x08, 0x21, 0x02, 0x00, 0x00, 0x00, 0x08, 0x21, - 0x02, 0xc0, 0xfb, 0x03, 0x08, 0x21, 0x02, 0x00, 0x00, 0x00, 0x08, 0x3f, - 0x02, 0xc0, 0xbd, 0x0f, 0x08, 0x01, 0x02, 0x00, 0x00, 0x00, 0x08, 0x01, - 0x02, 0xc0, 0x7f, 0x7b, 0x08, 0x01, 0x02, 0x00, 0x00, 0x00, 0x08, 0x01, - 0x02, 0x00, 0x00, 0x00, 0xf8, 0x01, 0x02, 0x00, 0x00, 0x00, 0x08, 0x00, - 0x02, 0x00, 0x00, 0x00, 0x08, 0x00, 0x02, 0x00, 0x00, 0x00, 0x08, 0x00, - 0x02, 0x00, 0x00, 0x00, 0x08, 0x00, 0x02, 0x00, 0x00, 0x00, 0x08, 0x00, - 0xfe, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/noletter.xbm b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/noletter.xbm @@ -1,27 +0,0 @@ -#define noletters_width 48 -#define noletters_height 48 -static char noletters_bits[] = { - 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xf0, 0x1f, 0x00, 0x00, - 0x00, 0x00, 0xff, 0xff, 0x01, 0x00, 0x00, 0xc0, 0xff, 0xff, 0x07, 0x00, - 0x00, 0xf0, 0x0f, 0xe0, 0x1f, 0x00, 0x00, 0xfc, 0x01, 0x00, 0x7f, 0x00, - 0x00, 0x3e, 0x00, 0x00, 0xf8, 0x00, 0x00, 0x1f, 0x00, 0x00, 0xf0, 0x01, - 0x80, 0x07, 0x00, 0x00, 0xc0, 0x03, 0xc0, 0x03, 0x00, 0x00, 0xe0, 0x07, - 0xe0, 0x01, 0x00, 0x00, 0xf0, 0x0f, 0xe0, 0x00, 0x00, 0x00, 0x78, 0x0e, - 0xf0, 0x00, 0x00, 0x00, 0x3c, 0x1e, 0x70, 0x00, 0x00, 0x00, 0x1e, 0x1c, - 0x38, 0x00, 0x00, 0x00, 0x0f, 0x38, 0x38, 0x00, 0x00, 0x80, 0x07, 0x38, - 0x3c, 0xfc, 0xff, 0xff, 0x7f, 0x78, 0x1c, 0x04, 0x00, 0xe0, 0x41, 0x70, - 0x1c, 0x04, 0x00, 0xf0, 0x40, 0x70, 0x1c, 0x74, 0x00, 0x78, 0x4e, 0x70, - 0x0e, 0x04, 0x00, 0x3c, 0x4a, 0xe0, 0x0e, 0x74, 0x03, 0x1e, 0x4a, 0xe0, - 0x0e, 0x04, 0x00, 0x0f, 0x4e, 0xe0, 0x0e, 0x04, 0x80, 0x07, 0x40, 0xe0, - 0x0e, 0x04, 0xf8, 0x0f, 0x40, 0xe0, 0x0e, 0x04, 0xe0, 0x01, 0x40, 0xe0, - 0x0e, 0x04, 0xf8, 0x00, 0x40, 0xe0, 0x0e, 0x04, 0x78, 0x00, 0x40, 0xe0, - 0x0e, 0x04, 0xfc, 0xf3, 0x40, 0xe0, 0x1c, 0x04, 0x1e, 0x00, 0x40, 0x70, - 0x1c, 0x04, 0x0f, 0x00, 0x40, 0x70, 0x1c, 0x84, 0x07, 0x00, 0x40, 0x70, - 0x3c, 0xfc, 0xff, 0xff, 0x7f, 0x78, 0x38, 0xe0, 0x01, 0x00, 0x00, 0x38, - 0x38, 0xf0, 0x00, 0x00, 0x00, 0x38, 0x70, 0x78, 0x00, 0x00, 0x00, 0x1c, - 0xf0, 0x3c, 0x00, 0x00, 0x00, 0x1e, 0xe0, 0x1e, 0x00, 0x00, 0x00, 0x0e, - 0xe0, 0x0f, 0x00, 0x00, 0x00, 0x0f, 0xc0, 0x07, 0x00, 0x00, 0x80, 0x07, - 0x80, 0x07, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x1f, 0x00, 0x00, 0xf0, 0x01, - 0x00, 0x3e, 0x00, 0x00, 0xf8, 0x00, 0x00, 0xfc, 0x01, 0x00, 0x7f, 0x00, - 0x00, 0xf0, 0x0f, 0xe0, 0x1f, 0x00, 0x00, 0xc0, 0xff, 0xff, 0x07, 0x00, - 0x00, 0x00, 0xff, 0xff, 0x01, 0x00, 0x00, 0x00, 0xf0, 0x1f, 0x00, 0x00}; diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/ouster.png b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/ouster.png Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/pattern.xbm b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/pattern.xbm @@ -1,6 +0,0 @@ -#define foo_width 16 -#define foo_height 16 -static char foo_bits[] = { - 0x60, 0x06, 0x90, 0x09, 0x90, 0x09, 0xb0, 0x0d, 0x4e, 0x72, 0x49, 0x92, - 0x71, 0x8e, 0x8e, 0x71, 0x8e, 0x71, 0x71, 0x8e, 0x49, 0x92, 0x4e, 0x72, - 0xb0, 0x0d, 0x90, 0x09, 0x90, 0x09, 0x60, 0x06}; diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/teapot.ppm b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/teapot.ppm @@ -1,31 +0,0 @@ -P6 -256 256 -255 -\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À[7 eOLjQLmSMoTMnSMlRMhPL_9 \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀnSMtVMzYN~[N~[N\N\O€\O€]O€]O€]O€]O€\O€\O}[NyYNtVM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀG- wXN}[N€]O„^O†_O†`O‡`Oˆ`Oˆ`OˆaO‰aO‰aO‰aO‰aO‰aO‰aOˆaOˆ`O†_Oƒ^O\N \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀaMLyYN…_O‰aP‹bPcPŽcPŽdPŽdPdPdPdPdPdPdPdPeP‘eP’eP’eP‘ePdPcP…_OpUM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀwXN…_OdP“fP•gQ–hQ˜hQ˜iQ™iQ™iQšiQšiQšjQ›jQ›jQœjQœjQœjQœjQœjQ›jQœjQ™iQ“fP‡`O\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJiQL‹bP—hQkQ¡mR¤nR¥oR¥oR¥oR¥oR¥oR¥oR¦oR¦oR¦pR¨pS©qSªqS«rS¬rS«rS©qS¤oRœjQ€]O\KK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀfOLrUMcPŸlR©qS¯tS²uTµwT·xT¸xT¹yTºyT»zT»zU¼zU¼zU¼zU»zUºyT¸xT¶wT¯tS¡mR‰aOhPL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\Àa0 cNLqUM€\O”fQ¦pS²wVºzV¿|VÂ}VÄVÆVÇ€VÉ‚WÌ…[Õeæ w÷³‹êª…Ĉg§qT“fQ{ZNYIK9 \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀO1 {G#‘JkRMqUMtVN–iS¨v\·€d¹bµzZ±vU°uT®sSªqS¤nRœjQ’eP„^OrUMHh>!T4 \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀG- V5 wE"~I#†M%U+¥e7²l:°g2®b*a(`(©^(¥])¡^-›]1ŠS,qC$`9 R3 G- \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À@) J/ i>!pA"tD"wF$yH&xH&tE$wE#yG%}M+ƒT4S5mE*Z7!K/ B* ;' \À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À‰aO¦oR½{UÇ€VÏ…X<( F- a: e<!h>!j@#k@$h>"d<!c=$hD-fF2[<)K0 @) ;' 5$ Ë‚VÇ€V¿|U_LKYIK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À…_O·xTÉ‚Wó«€ûµ‹Ö’k¼|X×>µf-¨^(¡Z'šW&–T&œN>) F- J/ b; g>#nD(jB&c<!b=%jH2_A/I0!<( 8& 5$ ”J¥Y ’S%8& ;' ?) E, <:HA=HE?IJAISFJYIKXIK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À£nRÁ}UܘqÊŠe±vU²e,™V&¥V†C€@ |> y< u: r9 o7 l6 -j5 -h4 -g3 -5$ D, K/ b; h>"wM1tK.e="a<#cA,U8&E- <( 9& .!a0 b1 c1 - -+ 3# @) 46G<:HMCIXHK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀU*´vT¿~X¸{YÃk+›W&‰N$|> u: p8 k5 -f3 -a0 _/ ]. [- I¡\*ª_(‘LkRMmSMmSMnSMnSMD, R3 W5 mA"|O0|P1j?"c<!a=%Y7"N1 F, ;' NCJNCJNDJODJODJODJh>!a: X/K% -g3 -a0 Z- \/ T*Q(ŠHµm8kRMmSMnTMoTMpTMpUM15G15G05G04G04GpUMpTM5^9 d<!yF#O+€N,rC#qB"pB#k?"a: Z7 6ODJPDJPEJQEJQEJREJREJREJRFJSFJSFJSFJSFJe<!X/ -^/ V+Q(L&I$r9 TlRMnSM46G47G47G46G46G46G46G46G36G36G25G25G15G04G/4F.3F - -X&pUMuWMwXNxXN<:H<:H<:H<:H<;H<;H<;H<;H=;H=;H=;H=;H>;H>;H?<H@<HA=HC>HG@ILBIREJ[JKcNLjQL§pR±uTºzUÃ~VÈWË‚XÖŽcäsÒŽe¼{V²vT¨pSžkR•gQŒbP†_O‚^O]O€\O€\O€\O€\O€]O]O]O]O]O]O]O]O]O]O]O€\O€\O~\N}[N|ZNxXN•T%H$ -›W&rVMvWNyYNzYN|ZN}[N}[N><H?<H?<H?<H?<H?<H@<H@<H@<HA=HA=HB=HC>HE?IG@IIAIKBIODJSFJWHK—hQŸlR§pR°b(¾i*Én+Ù|7Û|6Ïr,Íq+Êp-Ãl+»g)±b(®sS§pS lRšiQ•gQePcPŠaPˆaO‡`O‡`O†_O†_O…_O…_O…_O…_O…_O…_O…_O„_O„^O„^Oƒ^Oƒ^O‚]O]O€\O~[N{ZN•T% - - -@%<-$G?@…pfdNLuWM\NdNL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀTFJvWN‰aP./01„E}[N]O…_Oˆ`O‰aP‹bPŒbPcPcPŽcPdPdPdPeP‘eP’eP’eP“fP“fQ”fQ•gQ•gQ–gQ–hQ—hQ˜hQ™iQšiQ›jQœjQkQkRžlRŸlRžY&¤\'¨^'µ^½bÀcÃe Çi Äg Àc½b¼a¹`µ^´]¯X¢[' Z'žY&¢mR¡mR¡mR lRŸlRŸlRžkRkQœkQœjQ›jQšjQšiQ™iQ™iQ˜iQ˜hQ—hQ—hQ—hQ–gQ–gQ•gQ•gQ•gQ”fQ”fQ“fQ“fP’eP‘ePdPcP‰aP—O - B\À\À\À\À\À\À\À\À\À\À%7!!C*F#P) {dYœze»p€\OgPL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ`LKvWNŠaPm6 - -$ 5 ¬`(¶e)£nRœjQƒ^OJAI\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀXIK^KKdNLhPLuWM‚]OŒbP”fQePm6 -†`OŽcP“fQ—hQ˜hQ™iQšiQšjQ›jQ›jQ›jQœjQœjQœjQœkQkQkQkRžkRžkRžkRžlRŸlRŸlRŸlR lR lR lR¡mR¡mR¡mR¡mRºg)³c(²c(±b(V¿cÂe Åi!Åi!Àd ¼bº`¹`·_·_¶^¢Q§]'ª_(`(¹f)£nR£nR£nR£nR£nR£nR£nR¢nR¢nR¢nR¢nR¢nR¢nR¢mR¢mR¢mR¢mR¢mR¢mR¢mR¢mR¢mR¢nR¢mR¢mR£nR¢mR¢mR¡mR mRkR—hQˆGa0 ŠbP mRœjQ“fQ‰aP}[NrUMmSM…L$\À\À\À\À\À\À\À\À B B#C, 8& H. Z7 §pR›jQ{ZN\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀQEJ[JK`LKdNLhQLqUM{ZN…_OŽcP–gQ—hQ -‹bP‘eP–hQšiQ›jQœjQkQkQkRžkRžkRžlRžlRŸlRŸlRŸlRŸlRŸlR lR lR lR mR¡mR¡mR¡mR¡mR¡mR¢mR¢mR¢mR¢nR£nRÀj*ºg)·e)¶d)Âd°XÅg Åh Âe ¿c½b½b¾bªU`(®a(¯a(³c(¾i*¤oR¤oR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤nR¤oR¤oR¥oR¥oR¥oR¥oR¥oR¥oR¦oR¦oR¥oR¥oR¤nR¡mR›jQŽQ%Z- œjQ£nRŸlR—hQŽdP…_OuWMpTMnSMkRLa: \À\À\À\À\À\À\À B B&D 2 @* S6#G@IPDJ˜hQmSM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀVGJ]KKbMLeOLiQLlRMvWN\OˆaO‘eP—hQœjQ•gQ -!C +E'0F.4F7% 8% U/lG.SFJZIK]KKZIKB=H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀREJZJK`LKdNLgPLjQLlRMnSMpTMqUMtWMxXN{ZN~[N]O„^O†`O‰aO‹bPdP•gQ™iQœkQ lR¤nR§pSªrSsS¯tT²uT´vT¶wT·xT¹yT¹yTºyTºyT¹yT¶xT´vT¬rS¢nR—hQ¿|U¿|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ|UÀ}UÀ}UÁ}UÁ}UÁ}UÁ}UÂ}UÂ~UÃ~UÃ~VÃ~VÄVÅ€WÆX®a(ŸlRªrS´vT¸yT¼zU¾|UÁ~VÃXÆ‚[Ɇ_΋dÓ‘jÔ“mÔ“nБlÊŒhĆd½_¶{[°vWªsU¦pS¢nRžkRšiQ˜hQ•gQ“fQ‘ePdPŒbP‰aO†_Oƒ^O€\O|ZNxXNsVMpTMnTMmSMjQL€C B)D&/F-3F47G6% >" Y7 kA$YIK]KK^KKSFJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀVGJ\KKbMLeOLhPLkRLmSMnTMpTMrUMuWNyYN|ZN\N‚]O„_O‡`OŠaPŒbPŽcPeP“fP—hQ›jQžlR¢nR¥oS©qT¬sT¯uU²vU´wV¶xV¸yV¹yUºzU»zU¼{U½{U¾{U¾|U¿|U¿|U¿|U¿|U¾{U½{U¼{U¼zU»zTºyT¹yT¸xTµwT³vT´vT´vT´vT´wT´wTµwT·xT¹yTºzT¼zU½{U¾{U¿|UÀ|UÂ}UÄVÅ€WÇ‚YÉ„\͈_ÑŒdÙ”láuç£|쩂ſtî‡ëª…æ¦ÞŸ{Õ—sËŽl†d¹^³yZuW¨qU¤oSŸlRžkRœjQšiQ˜hQ–gQ”fQ‘ePdPcPŠaP‡`O„^O]O}[NyYNuWMpTMoTMmSMkRLgPL&D#.E,3F46G;' <( D"iB(VGJ]KK`LK[JKB>H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJYIK^LKcNLfOLiQLkRMmSMoTMqUMsVMvXNzYN}[N€\O‚^O…_Oˆ`OŠaPŒcPdP‘eP“fQ•gQ—hQ™iQkR mS¤oT¨rU¬tW°wY´zZ¸}\»]¾€^À^Á‚^‚^Â\Á€ZÁYÁXÁ~WÁ~WÂ~VÂ~VÂ~VÃ~VÃ~UÃ~UÄ~UÄ~UÄUÄUÅVÅVÅVÅVÆVÆ€VÆ€VÇ€WÇWÈ‚XɃZË…[͇^ЊaÓdØ’iÜ—nâtè£zî©ó¯‡ø´û¸‘üº“û¹“÷¶ñ±Œé©…à¡~Ö˜vËmÇf»€`´z[®vX©rU¥pT£oS¢nS lRžkRœkRšjQ˜iQ–hQ”fQ’ePdPcP‹bPˆ`O…_O‚]O~[NzYNvWNpTMoTMnSMkRMhQLo7 ,2F36G99HC+ @ ]8 nA"\JK`ML_LKSFJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ[JK`LKdNLgPLjQLlRMnSMpTMqUMtVMwXNzZN}[N€]Oƒ^O†_OˆaO‹bPcPdP‘eP“fQ•gQ—hQ™iQ›jRžlR mS£oU§rW¬vZ²{]¹€a¿…fÅŠjËnГqÓ•sÕ–sÕ–rÕ–qÕ”oÓ’mÑjÏgÍŠcˈaɆ^È„\Ç‚[ÆYÅ€XÅ€WÅWÅWÅVÅVÅWÅ€WÆ€WÇXÈ‚YɃ[Ê…\͇_ÏŠaÒeÕ‘hÙ•mÝ™qávä¡zç¤}ê§€ë©ƒëª„é¨ƒå¥€ß |Ù›wÓ•rÌmƉh¿„c¸~^²yZ®vX¬tWªsV¨qU¦pT¤oS¢nS mRžlRœkR›jQ™iQ—hQ•gQ“fPePŽcP‹bPˆaO…_O‚^O\N{ZNwXNsVMoTMnSMlRMiQL~I#26G99G?<HA* E$ i@$ZIKaMLbML[JK;:H\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀWHJ]KKbMLeOLhPLjRLlSMnTMpTMrUMuWMxXN{ZN~\N]O„^O†`O‰aO‹bPŽcPdP’eP”fQ–gQ˜hQšiQœkRžlS mT£oU¦rWªuZ¯y]´~aºƒfŠlË’sÔšzÜ¡€ã§†è«‰ë®‹í¯Œí®‹ë¬ˆè¨„ã£~ßžyÚ™tÖ•oÒjÎŒfˈbÈ…_ƃ\ÅZÄ€YÃXÂWÂ~WÂ~WÂ~WÃXÀXÄ€YÅZƃ\Ç…^Ɇ`ˈbÌŠdÍ‹fÎgÎŽiÎŽjÎŽjÍŽjËŒiljgÆd¿ƒaº^¸}]¶|\´{[²yZ°xY®vX¬tWªsV¨qU¦pT¤oS¢nS mRžlRkR›jQ™iQ—hQ•gQ“fP‘ePŽdPŒbP‰aO†_Oƒ^O€\O|ZNxXNtVMpTMnSMmSMjQLgPL99G?<HG- E&b;!YIK`MLdOM`LKNCJ\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀŸlRºyTÄ~UÊ‚XʃYÄXº{WtUšW'¢[(—hQ lRcP€\OhQL\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀNCJYIK^LKcNLfOLiQLkRLmSMoTMqUMrVMvWNyYN|ZN\N‚]O„_O‡`O‰aPŒbPŽcPdP’fP”gQ–hQ˜iQšjRœkRžlS¡nT¤pU§sW«vZ°z]µb»„gŠlÉ‘sИyØžÞ¤…ã©Šèì±ï³‘ﳑëŠç©…⣀ݞzؘtÒ“nÎiɉdÆ…`Â]Á€[¿~Y¾}X½|W½|V¼{V¼{V¼{V¼{V¼{V¼|W¼|W½}X½}Y½~Z½~Z¼~Z»}[º}[º}[º~\º~\º~]º~]¹~]¸~]·}]¶|\´z[²yZ°wY®vX¬tWªsV¨rU¦pT¤oS¢nS mRŸlRkR›jQšiQ˜hQ–gQ“fQ‘ePdPŒcPŠaP‡`O„^O]O}[NyYNuWNpTMnTMmSMkRLhPL|H$D>IQ2 P+XHK_LLfQOcNLXIK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À©qSºyTÃ~VΈ`遲ޜv¾€]ªqS–LŽG|> g3 -S)? *%.—hQ—hQ‘eP‡`OuWM\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀSFJ[JK`LKdNLgPLjQLlRMnSMoTMqUMsVMwXNzYN}[N€\O‚^O…_O‡`OŠaPŒbPŽdP‘eP“fP•gQ—hQ˜iQšjRœkRŸlS¡nT¤pV§sX«vZ°z^¶b¼…gËmÊ’sјzØŸ€Þ¤…ã©Šèê¯ë°ê¯Žè¬‹å¨‡à¤‚Ûž|Ö™wÑ“qÌŽlljgÃ…bÀ‚_½\»}Zº{X¹zW¸yV·yU·xU·xU·xT·xT·xU·xU·xU·yV·yV·yW¸zW¸{X¹{Y¹|Zº}[º}[º}\º~\¹~]¹~]¸}]·|\µ{\´z[²yZ°wY®vX¬tWªsV¨rU¦pT¤oS¢nS¡mRŸlRkRœjQšiQ˜hQ–gQ”fQ’ePdPcPŠbP‡`O…_O‚]O~[NzZNvWNrUMoTMmSMlRMiQLeOLJAIJ(h>!]KKfQOgQN_LKD>I\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À™iQ°tS¸yT¼{UÂYÎŒeïˆô´Õ—u¶|\ Z'™LˆD|> - - & 3#.$ -% .% .& /&!,# ,# @70A71XNHXNHWNHWNHZRLYQLYQLXQLWQLWPLUOLSNLQMKOLJMJJ0//.-.,,-&(+ "( !' - % ' %$#" ! !$ -\ No newline at end of file diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/items.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/items.tcl @@ -1,291 +0,0 @@ -# items.tcl -- -# -# This demonstration script creates a canvas that displays the -# canvas item types. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .items -catch {destroy $w} -toplevel $w -wm title $w "Canvas Item Demonstration" -wm iconname $w "Items" -positionWindow $w -set c $w.frame.c - -label $w.msg -font $font -wraplength 5i -justify left -text "This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -frame $w.frame -pack $w.frame -side top -fill both -expand yes - -canvas $c -scrollregion {0c 0c 30c 24c} -width 15c -height 10c \ - -relief sunken -borderwidth 2 \ - -xscrollcommand "$w.frame.hscroll set" \ - -yscrollcommand "$w.frame.vscroll set" -ttk::scrollbar $w.frame.vscroll -command "$c yview" -ttk::scrollbar $w.frame.hscroll -orient horiz -command "$c xview" - -grid $c -in $w.frame \ - -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news -grid $w.frame.vscroll \ - -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news -grid $w.frame.hscroll \ - -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news -grid rowconfig $w.frame 0 -weight 1 -minsize 0 -grid columnconfig $w.frame 0 -weight 1 -minsize 0 - -# Display a 3x3 rectangular grid. - -$c create rect 0c 0c 30c 24c -width 2 -$c create line 0c 8c 30c 8c -width 2 -$c create line 0c 16c 30c 16c -width 2 -$c create line 10c 0c 10c 24c -width 2 -$c create line 20c 0c 20c 24c -width 2 - -set font1 {Helvetica 12} -set font2 {Helvetica 24 bold} -if {[winfo depth $c] > 1} { - set blue DeepSkyBlue3 - set red red - set bisque bisque3 - set green SeaGreen3 -} else { - set blue black - set red black - set bisque black - set green black -} - -# Set up demos within each of the areas of the grid. - -$c create text 5c .2c -text Lines -anchor n -$c create line 1c 1c 3c 1c 1c 4c 3c 4c -width 2m -fill $blue \ - -cap butt -join miter -tags item -$c create line 4.67c 1c 4.67c 4c -arrow last -tags item -$c create line 6.33c 1c 6.33c 4c -arrow both -tags item -$c create line 5c 6c 9c 6c 9c 1c 8c 1c 8c 4.8c 8.8c 4.8c 8.8c 1.2c \ - 8.2c 1.2c 8.2c 4.6c 8.6c 4.6c 8.6c 1.4c 8.4c 1.4c 8.4c 4.4c \ - -width 3 -fill $red -tags item -# Main widget program sets variable tk_demoDirectory -$c create line 1c 5c 7c 5c 7c 7c 9c 7c -width .5c \ - -stipple @[file join $tk_demoDirectory images gray25.xbm] \ - -arrow both -arrowshape {15 15 7} -tags item -$c create line 1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c -width .5c \ - -cap round -join round -tags item - -$c create text 15c .2c -text "Curves (smoothed lines)" -anchor n -$c create line 11c 4c 11.5c 1c 13.5c 1c 14c 4c -smooth on \ - -fill $blue -tags item -$c create line 15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c -smooth on \ - -arrow both -width 3 -tags item -$c create line 12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c \ - 16.5c 4.5c 13.5c 7.5c 12c 6c -smooth on -width 3m -cap round \ - -stipple @[file join $tk_demoDirectory images gray25.xbm] \ - -fill $red -tags item - -$c create text 25c .2c -text Polygons -anchor n -$c create polygon 21c 1.0c 22.5c 1.75c 24c 1.0c 23.25c 2.5c \ - 24c 4.0c 22.5c 3.25c 21c 4.0c 21.75c 2.5c -fill $green \ - -outline black -width 4 -tags item -$c create polygon 25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c \ - 29c 1c 29c 4c 29c 4c -fill $red -smooth on -tags item -$c create polygon 22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c \ - 28c 5.25c 24c 5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c \ - -stipple @[file join $tk_demoDirectory images gray25.xbm] \ - -outline black -tags item - -$c create text 5c 8.2c -text Rectangles -anchor n -$c create rectangle 1c 9.5c 4c 12.5c -outline $red -width 3m -tags item -$c create rectangle 0.5c 13.5c 4.5c 15.5c -fill $green -tags item -$c create rectangle 6c 10c 9c 15c -outline {} \ - -stipple @[file join $tk_demoDirectory images gray25.xbm] \ - -fill $blue -tags item - -$c create text 15c 8.2c -text Ovals -anchor n -$c create oval 11c 9.5c 14c 12.5c -outline $red -width 3m -tags item -$c create oval 10.5c 13.5c 14.5c 15.5c -fill $green -tags item -$c create oval 16c 10c 19c 15c -outline {} \ - -stipple @[file join $tk_demoDirectory images gray25.xbm] \ - -fill $blue -tags item - -$c create text 25c 8.2c -text Text -anchor n -$c create rectangle 22.4c 8.9c 22.6c 9.1c -$c create text 22.5c 9c -anchor n -font $font1 -width 4c \ - -text "A short string of text, word-wrapped, justified left, and anchored north (at the top). The rectangles show the anchor points for each piece of text." -tags item -$c create rectangle 25.4c 10.9c 25.6c 11.1c -$c create text 25.5c 11c -anchor w -font $font1 -fill $blue \ - -text "Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge." \ - -justify center -tags item -$c create rectangle 24.9c 13.9c 25.1c 14.1c -$c create text 25c 14c -font $font2 -anchor c -fill $red -angle 15 \ - -text "Angled characters" -tags item - -$c create text 5c 16.2c -text Arcs -anchor n -$c create arc 0.5c 17c 7c 20c -fill $green -outline black \ - -start 45 -extent 270 -style pieslice -tags item -$c create arc 6.5c 17c 9.5c 20c -width 4m -style arc \ - -outline $blue -start -135 -extent 270 -tags item \ - -outlinestipple @[file join $tk_demoDirectory images gray25.xbm] -$c create arc 0.5c 20c 9.5c 24c -width 4m -style pieslice \ - -fill {} -outline $red -start 225 -extent -90 -tags item -$c create arc 5.5c 20.5c 9.5c 23.5c -width 4m -style chord \ - -fill $blue -outline {} -start 45 -extent 270 -tags item - -image create photo items.ousterhout \ - -file [file join $tk_demoDirectory images ouster.png] -image create photo items.ousterhout.active -format "png -alpha 0.5" \ - -file [file join $tk_demoDirectory images ouster.png] -$c create text 15c 16.2c -text "Bitmaps and Images" -anchor n -$c create image 13c 20c -tags item -image items.ousterhout \ - -activeimage items.ousterhout.active -$c create bitmap 17c 18.5c -tags item \ - -bitmap @[file join $tk_demoDirectory images noletter.xbm] -$c create bitmap 17c 21.5c -tags item \ - -bitmap @[file join $tk_demoDirectory images letters.xbm] - -$c create text 25c 16.2c -text Windows -anchor n -button $c.button -text "Press Me" -command "butPress $c $red" -$c create window 21c 18c -window $c.button -anchor nw -tags item -entry $c.entry -width 20 -relief sunken -$c.entry insert end "Edit this text" -$c create window 21c 21c -window $c.entry -anchor nw -tags item -scale $c.scale -from 0 -to 100 -length 6c -sliderlength .4c \ - -width .5c -tickinterval 0 -$c create window 28.5c 17.5c -window $c.scale -anchor n -tags item -$c create text 21c 17.9c -text Button: -anchor sw -$c create text 21c 20.9c -text Entry: -anchor sw -$c create text 28.5c 17.4c -text Scale: -anchor s - -# Set up event bindings for canvas: - -$c bind item <Any-Enter> "itemEnter $c" -$c bind item <Any-Leave> "itemLeave $c" -bind $c <2> "$c scan mark %x %y" -bind $c <B2-Motion> "$c scan dragto %x %y" -bind $c <3> "itemMark $c %x %y" -bind $c <B3-Motion> "itemStroke $c %x %y" -bind $c <<NextChar>> "itemsUnderArea $c" -bind $c <1> "itemStartDrag $c %x %y" -bind $c <B1-Motion> "itemDrag $c %x %y" - -# Utility procedures for highlighting the item under the pointer: - -proc itemEnter {c} { - global restoreCmd - - if {[winfo depth $c] == 1} { - set restoreCmd {} - return - } - set type [$c type current] - if {$type == "window" || $type == "image"} { - set restoreCmd {} - return - } elseif {$type == "bitmap"} { - set bg [lindex [$c itemconf current -background] 4] - set restoreCmd [list $c itemconfig current -background $bg] - $c itemconfig current -background SteelBlue2 - return - } elseif {$type == "image"} { - set restoreCmd [list $c itemconfig current -state normal] - $c itemconfig current -state active - return - } - set fill [lindex [$c itemconfig current -fill] 4] - if {(($type == "rectangle") || ($type == "oval") || ($type == "arc")) - && ($fill == "")} { - set outline [lindex [$c itemconfig current -outline] 4] - set restoreCmd "$c itemconfig current -outline $outline" - $c itemconfig current -outline SteelBlue2 - } else { - set restoreCmd "$c itemconfig current -fill $fill" - $c itemconfig current -fill SteelBlue2 - } -} - -proc itemLeave {c} { - global restoreCmd - - eval $restoreCmd -} - -# Utility procedures for stroking out a rectangle and printing what's -# underneath the rectangle's area. - -proc itemMark {c x y} { - global areaX1 areaY1 - set areaX1 [$c canvasx $x] - set areaY1 [$c canvasy $y] - $c delete area -} - -proc itemStroke {c x y} { - global areaX1 areaY1 areaX2 areaY2 - set x [$c canvasx $x] - set y [$c canvasy $y] - if {($areaX1 != $x) && ($areaY1 != $y)} { - $c delete area - $c addtag area withtag [$c create rect $areaX1 $areaY1 $x $y \ - -outline black] - set areaX2 $x - set areaY2 $y - } -} - -proc itemsUnderArea {c} { - global areaX1 areaY1 areaX2 areaY2 - set area [$c find withtag area] - set items "" - foreach i [$c find enclosed $areaX1 $areaY1 $areaX2 $areaY2] { - if {[lsearch [$c gettags $i] item] != -1} { - lappend items $i - } - } - puts stdout "Items enclosed by area: $items" - set items "" - foreach i [$c find overlapping $areaX1 $areaY1 $areaX2 $areaY2] { - if {[lsearch [$c gettags $i] item] != -1} { - lappend items $i - } - } - puts stdout "Items overlapping area: $items" -} - -set areaX1 0 -set areaY1 0 -set areaX2 0 -set areaY2 0 - -# Utility procedures to support dragging of items. - -proc itemStartDrag {c x y} { - global lastX lastY - set lastX [$c canvasx $x] - set lastY [$c canvasy $y] -} - -proc itemDrag {c x y} { - global lastX lastY - set x [$c canvasx $x] - set y [$c canvasy $y] - $c move current [expr {$x-$lastX}] [expr {$y-$lastY}] - set lastX $x - set lastY $y -} - -# Procedure that's invoked when the button embedded in the canvas -# is invoked. - -proc butPress {w color} { - set i [$w create text 25c 18.1c -text "Oooohhh!!" -fill $color -anchor n] - after 500 "$w delete $i" -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/ixset b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/ixset @@ -1,328 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish8.6 "$0" ${1+"$@"} - -# ixset -- -# A nice interface to "xset" to change X server settings -# -# History : -# 91/11/23 : pda@masi.ibp.fr, jt@ratp.fr : design -# 92/08/01 : pda@masi.ibp.fr : cleaning - -package require Tk - -# -# Button actions -# - -proc quit {} { - destroy . -} - -proc ok {} { - writesettings - quit -} - -proc cancel {} { - readsettings - dispsettings - .buttons.apply configure -state disabled - .buttons.cancel configure -state disabled -} - -proc apply {} { - writesettings - .buttons.apply configure -state disabled - .buttons.cancel configure -state disabled -} - -# -# Read current settings -# - -proc readsettings {} { - global kbdrep ; set kbdrep "on" - global kbdcli ; set kbdcli 0 - global bellvol ; set bellvol 100 - global bellpit ; set bellpit 440 - global belldur ; set belldur 100 - global mouseacc ; set mouseacc "3/1" - global mousethr ; set mousethr 4 - global screenbla ; set screenbla "blank" - global screentim ; set screentim 600 - global screencyc ; set screencyc 600 - - set xfd [open "|xset q" r] - while {[gets $xfd line] > -1} { - switch -- [lindex $line 0] { - auto { - set rpt [lindex $line 1] - if {$rpt eq "repeat:"} { - set kbdrep [lindex $line 2] - set kbdcli [lindex $line 6] - } - } - bell { - set bellvol [lindex $line 2] - set bellpit [lindex $line 5] - set belldur [lindex $line 8] - } - acceleration: { - set mouseacc [lindex $line 1] - set mousethr [lindex $line 3] - } - prefer { - set bla [lindex $line 2] - set screenbla [expr {$bla eq "yes" ? "blank" : "noblank"}] - } - timeout: { - set screentim [lindex $line 1] - set screencyc [lindex $line 3] - } - } - } - close $xfd - - # puts stdout [format "Key REPEAT = %s\n" $kbdrep] - # puts stdout [format "Key CLICK = %s\n" $kbdcli] - # puts stdout [format "Bell VOLUME = %s\n" $bellvol] - # puts stdout [format "Bell PITCH = %s\n" $bellpit] - # puts stdout [format "Bell DURATION = %s\n" $belldur] - # puts stdout [format "Mouse ACCELERATION = %s\n" $mouseacc] - # puts stdout [format "Mouse THRESHOLD = %s\n" $mousethr] - # puts stdout [format "Screen BLANCK = %s\n" $screenbla] - # puts stdout [format "Screen TIMEOUT = %s\n" $screentim] - # puts stdout [format "Screen CYCLE = %s\n" $screencyc] -} - - -# -# Write settings into the X server -# - -proc writesettings {} { - global kbdrep kbdcli bellvol bellpit belldur - global mouseacc mousethr screenbla screentim screencyc - - set bellvol [.bell.vol get] - set bellpit [.bell.val.pit.entry get] - set belldur [.bell.val.dur.entry get] - - if {$kbdrep eq "on"} { - set kbdcli [.kbd.val.cli get] - } else { - set kbdcli "off" - } - - set mouseacc [.mouse.hor.acc.entry get] - set mousethr [.mouse.hor.thr.entry get] - - set screentim [.screen.tim.entry get] - set screencyc [.screen.cyc.entry get] - - exec xset \ - b $bellvol $bellpit $belldur \ - c $kbdcli \ - r $kbdrep \ - m $mouseacc $mousethr \ - s $screentim $screencyc \ - s $screenbla -} - - -# -# Sends all settings to the window -# - -proc dispsettings {} { - global kbdrep kbdcli bellvol bellpit belldur - global mouseacc mousethr screenbla screentim screencyc - - .bell.vol set $bellvol - .bell.val.pit.entry delete 0 end - .bell.val.pit.entry insert 0 $bellpit - .bell.val.dur.entry delete 0 end - .bell.val.dur.entry insert 0 $belldur - - .kbd.val.onoff [expr {$kbdrep eq "on" ? "select" : "deselect"}] - .kbd.val.cli set $kbdcli - - .mouse.hor.acc.entry delete 0 end - .mouse.hor.acc.entry insert 0 $mouseacc - .mouse.hor.thr.entry delete 0 end - .mouse.hor.thr.entry insert 0 $mousethr - - .screen.blank [expr {$screenbla eq "blank" ? "select" : "deselect"}] - .screen.pat [expr {$screenbla ne "blank" ? "select" : "deselect"}] - .screen.tim.entry delete 0 end - .screen.tim.entry insert 0 $screentim - .screen.cyc.entry delete 0 end - .screen.cyc.entry insert 0 $screencyc -} - - -# -# Create all windows, and pack them -# - -proc labelentry {path text length {range {}}} { - frame $path - label $path.label -text $text - if {[llength $range]} { - spinbox $path.entry -width $length -relief sunken \ - -from [lindex $range 0] -to [lindex $range 1] - } else { - entry $path.entry -width $length -relief sunken - } - pack $path.label -side left - pack $path.entry -side right -expand y -fill x -} - -proc createwindows {} { - # - # Buttons - # - - frame .buttons - button .buttons.ok -default active -command ok -text "Ok" - button .buttons.apply -default normal -command apply -text "Apply" \ - -state disabled - button .buttons.cancel -default normal -command cancel -text "Cancel" \ - -state disabled - button .buttons.quit -default normal -command quit -text "Quit" - - pack .buttons.ok .buttons.apply .buttons.cancel .buttons.quit \ - -side left -expand yes -pady 5 - - bind . <Return> {.buttons.ok flash; .buttons.ok invoke} - bind . <Escape> {.buttons.quit flash; .buttons.quit invoke} - bind . <1> { - if {![string match .buttons* %W]} { - .buttons.apply configure -state normal - .buttons.cancel configure -state normal - } - } - bind . <Key> { - if {![string match .buttons* %W]} { - switch -glob %K { - Return - Escape - Tab - *Shift* {} - default { - .buttons.apply configure -state normal - .buttons.cancel configure -state normal - } - } - } - } - - # - # Bell settings - # - - labelframe .bell -text "Bell Settings" -padx 1.5m -pady 1.5m - scale .bell.vol \ - -from 0 -to 100 -length 200 -tickinterval 20 \ - -label "Volume (%)" -orient horizontal - - frame .bell.val - labelentry .bell.val.pit "Pitch (Hz)" 6 {25 20000} - labelentry .bell.val.dur "Duration (ms)" 6 {1 10000} - pack .bell.val.pit -side left -padx 5 - pack .bell.val.dur -side right -padx 5 - pack .bell.vol .bell.val -side top -expand yes - - # - # Keyboard settings - # - - labelframe .kbd -text "Keyboard Repeat Settings" -padx 1.5m -pady 1.5m - - frame .kbd.val - checkbutton .kbd.val.onoff \ - -text "On" \ - -onvalue "on" -offvalue "off" -variable kbdrep \ - -relief flat - scale .kbd.val.cli \ - -from 0 -to 100 -length 200 -tickinterval 20 \ - -label "Click Volume (%)" -orient horizontal - pack .kbd.val.onoff -side left -fill x -expand yes -padx {0 1m} - pack .kbd.val.cli -side left -expand yes -fill x -padx {1m 0} - - pack .kbd.val -side top -expand yes -pady 2 -fill x - - # - # Mouse settings - # - - labelframe .mouse -text "Mouse Settings" -padx 1.5m -pady 1.5m - - frame .mouse.hor - labelentry .mouse.hor.acc "Acceleration" 5 - labelentry .mouse.hor.thr "Threshold (pixels)" 3 {1 2000} - - pack .mouse.hor.acc -side left -padx {0 1m} - pack .mouse.hor.thr -side right -padx {1m 0} - - pack .mouse.hor -side top -expand yes - - # - # Screen Saver settings - # - - labelframe .screen -text "Screen-saver Settings" -padx 1.5m -pady 1.5m - - radiobutton .screen.blank \ - -variable screenblank -text "Blank" -relief flat \ - -value "blank" -variable screenbla -anchor w - radiobutton .screen.pat \ - -variable screenblank -text "Pattern" -relief flat \ - -value "noblank" -variable screenbla -anchor w - labelentry .screen.tim "Timeout (s)" 5 {1 100000} - labelentry .screen.cyc "Cycle (s)" 5 {1 100000} - - grid .screen.blank .screen.tim -sticky e - grid .screen.pat .screen.cyc -sticky e - grid configure .screen.blank .screen.pat -sticky ew - - # - # Main window - # - - pack .buttons -side top -fill both - pack .bell .kbd .mouse .screen -side top -fill both -expand yes \ - -padx 1m -pady 1m - - # - # Let the user resize our window - # - wm minsize . 10 10 -} - -############################################################################## -# Main program - -# -# Listen what "xset" tells us... -# - -readsettings - -# -# Create all windows -# - -createwindows - -# -# Write xset parameters -# - -dispsettings - -# -# Now, wait for user actions... -# - -# Local Variables: -# mode: tcl -# End: diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/knightstour.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/knightstour.tcl @@ -1,268 +0,0 @@ -# Copyright (C) 2008 Pat Thoyts <patthoyts@users.sourceforge.net> -# -# Calculate a Knight's tour of a chessboard. -# -# This uses Warnsdorff's rule to calculate the next square each -# time. This specifies that the next square should be the one that -# has the least number of available moves. -# -# Using this rule it is possible to get to a position where -# there are no squares available to move into. In this implementation -# this occurs when the starting square is d6. -# -# To solve this fault an enhancement to the rule is that if we -# have a choice of squares with an equal score, we should choose -# the one nearest the edge of the board. -# -# If the call to the Edgemost function is commented out you can see -# this occur. -# -# You can drag the knight to a specific square to start if you wish. -# If you let it repeat then it will choose random start positions -# for each new tour. - -package require Tk 8.5 - -# Return a list of accessible squares from a given square -proc ValidMoves {square} { - set moves {} - foreach pair {{-1 -2} {-2 -1} {-2 1} {-1 2} {1 2} {2 1} {2 -1} {1 -2}} { - set col [expr {($square % 8) + [lindex $pair 0]}] - set row [expr {($square / 8) + [lindex $pair 1]}] - if {$row > -1 && $row < 8 && $col > -1 && $col < 8} { - lappend moves [expr {$row * 8 + $col}] - } - } - return $moves -} - -# Return the number of available moves for this square -proc CheckSquare {square} { - variable visited - set moves 0 - foreach test [ValidMoves $square] { - if {[lsearch -exact -integer $visited $test] == -1} { - incr moves - } - } - return $moves -} - -# Select the next square to move to. Returns -1 if there are no available -# squares remaining that we can move to. -proc Next {square} { - variable visited - set minimum 9 - set nextSquare -1 - foreach testSquare [ValidMoves $square] { - if {[lsearch -exact -integer $visited $testSquare] == -1} { - set count [CheckSquare $testSquare] - if {$count < $minimum} { - set minimum $count - set nextSquare $testSquare - } elseif {$count == $minimum} { - # to remove the enhancement to Warnsdorff's rule - # remove the next line: - set nextSquare [Edgemost $nextSquare $testSquare] - } - } - } - return $nextSquare -} - -# Select the square nearest the edge of the board -proc Edgemost {a b} { - set colA [expr {3-int(abs(3.5-($a%8)))}] - set colB [expr {3-int(abs(3.5-($b%8)))}] - set rowA [expr {3-int(abs(3.5-($a/8)))}] - set rowB [expr {3-int(abs(3.5-($b/8)))}] - return [expr {($colA * $rowA) < ($colB * $rowB) ? $a : $b}] -} - -# Display a square number as a standard chess square notation. -proc N {square} { - return [format %c%d [expr {97 + $square % 8}] \ - [expr {$square / 8 + 1}]] -} - -# Perform a Knight's move and schedule the next move. -proc MovePiece {dlg last square} { - variable visited - variable delay - variable continuous - $dlg.f.txt insert end "[llength $visited]. [N $last] .. [N $square]\n" {} - $dlg.f.txt see end - $dlg.f.c itemconfigure [expr {1+$last}] -state normal -outline black - $dlg.f.c itemconfigure [expr {1+$square}] -state normal -outline red - $dlg.f.c moveto knight {*}[lrange [$dlg.f.c coords [expr {1+$square}]] 0 1] - lappend visited $square - set next [Next $square] - if {$next ne -1} { - variable aid [after $delay [list MovePiece $dlg $square $next]] - } else { - $dlg.tf.b1 configure -state normal - if {[llength $visited] == 64} { - variable initial - if {$initial == $square} { - $dlg.f.txt insert end "Closed tour!" - } else { - $dlg.f.txt insert end "Success\n" {} - if {$continuous} { - after [expr {$delay * 2}] [namespace code \ - [list Tour $dlg [expr {int(rand() * 64)}]]] - } - } - } else { - $dlg.f.txt insert end "FAILED!\n" {} - } - } -} - -# Begin a new tour of the board given a random start position -proc Tour {dlg {square {}}} { - variable visited {} - $dlg.f.txt delete 1.0 end - $dlg.tf.b1 configure -state disabled - for {set n 0} {$n < 64} {incr n} { - $dlg.f.c itemconfigure $n -state disabled -outline black - } - if {$square eq {}} { - set coords [lrange [$dlg.f.c coords knight] 0 1] - set square [expr {[$dlg.f.c find closest {*}$coords 0 65]-1}] - } - variable initial $square - after idle [list MovePiece $dlg $initial $initial] -} - -proc Stop {} { - variable aid - catch {after cancel $aid} -} - -proc Exit {dlg} { - Stop - destroy $dlg -} - -proc SetDelay {new} { - variable delay [expr {int($new)}] -} - -proc DragStart {w x y} { - $w dtag selected - $w addtag selected withtag current - variable dragging [list $x $y] -} -proc DragMotion {w x y} { - variable dragging - if {[info exists dragging]} { - $w move selected [expr {$x - [lindex $dragging 0]}] \ - [expr {$y - [lindex $dragging 1]}] - variable dragging [list $x $y] - } -} -proc DragEnd {w x y} { - set square [$w find closest $x $y 0 65] - $w moveto selected {*}[lrange [$w coords $square] 0 1] - $w dtag selected - variable dragging ; unset dragging -} - -proc CreateGUI {} { - catch {destroy .knightstour} - set dlg [toplevel .knightstour] - wm title $dlg "Knights tour" - wm withdraw $dlg - set f [ttk::frame $dlg.f] - set c [canvas $f.c -width 240 -height 240] - text $f.txt -width 10 -height 1 -background white \ - -yscrollcommand [list $f.vs set] -font {Arial 8} - ttk::scrollbar $f.vs -command [list $f.txt yview] - - variable delay 600 - variable continuous 0 - ttk::frame $dlg.tf - ttk::label $dlg.tf.ls -text Speed - ttk::scale $dlg.tf.sc -from 8 -to 2000 -command [list SetDelay] \ - -variable [namespace which -variable delay] - ttk::checkbutton $dlg.tf.cc -text Repeat \ - -variable [namespace which -variable continuous] - ttk::button $dlg.tf.b1 -text Start -command [list Tour $dlg] - ttk::button $dlg.tf.b2 -text Exit -command [list Exit $dlg] - set square 0 - for {set row 7} {$row != -1} {incr row -1} { - for {set col 0} {$col < 8} {incr col} { - if {(($col & 1) ^ ($row & 1))} { - set fill tan3 ; set dfill tan4 - } else { - set fill bisque ; set dfill bisque3 - } - set coords [list [expr {$col * 30 + 4}] [expr {$row * 30 + 4}] \ - [expr {$col * 30 + 30}] [expr {$row * 30 + 30}]] - $c create rectangle $coords -fill $fill -disabledfill $dfill \ - -width 2 -state disabled - } - } - if {[tk windowingsystem] ne "x11"} { - catch {eval font create KnightFont -size -24} - $c create text 0 0 -font KnightFont -text "\u265e" \ - -anchor nw -tags knight -fill black -activefill "#600000" - } else { - # On X11 we cannot reliably tell if the \u265e glyph is available - # so just use a polygon - set pts { - 2 25 24 25 21 19 20 8 14 0 10 0 0 13 0 16 - 2 17 4 14 5 15 3 17 5 17 9 14 10 15 5 21 - } - $c create polygon $pts -tag knight -offset 8 \ - -fill black -activefill "#600000" - } - $c moveto knight {*}[lrange [$c coords [expr {1 + int(rand() * 64)}]] 0 1] - $c bind knight <ButtonPress-1> [namespace code [list DragStart %W %x %y]] - $c bind knight <Motion> [namespace code [list DragMotion %W %x %y]] - $c bind knight <ButtonRelease-1> [namespace code [list DragEnd %W %x %y]] - - grid $c $f.txt $f.vs -sticky news - grid rowconfigure $f 0 -weight 1 - grid columnconfigure $f 1 -weight 1 - - grid $f - - - - - -sticky news - set things [list $dlg.tf.ls $dlg.tf.sc $dlg.tf.cc $dlg.tf.b1] - if {![info exists ::widgetDemo]} { - lappend things $dlg.tf.b2 - if {[tk windowingsystem] ne "aqua"} { - set things [linsert $things 0 [ttk::sizegrip $dlg.tf.sg]] - } - } - pack {*}$things -side right - if {[tk windowingsystem] eq "aqua"} { - pack configure {*}$things -padx {4 4} -pady {12 12} - pack configure [lindex $things 0] -padx {4 24} - pack configure [lindex $things end] -padx {16 4} - } - grid $dlg.tf - - - - - -sticky ew - if {[info exists ::widgetDemo]} { - grid [addSeeDismiss $dlg.buttons $dlg] - - - - - -sticky ew - } - - grid rowconfigure $dlg 0 -weight 1 - grid columnconfigure $dlg 0 -weight 1 - - bind $dlg <Control-F2> {console show} - bind $dlg <Return> [list $dlg.tf.b1 invoke] - bind $dlg <Escape> [list $dlg.tf.b2 invoke] - bind $dlg <Destroy> [namespace code [list Stop]] - wm protocol $dlg WM_DELETE_WINDOW [namespace code [list Exit $dlg]] - - wm deiconify $dlg - tkwait window $dlg -} - -if {![winfo exists .knightstour]} { - if {![info exists widgetDemo]} { wm withdraw . } - set r [catch [linsert $argv 0 CreateGUI] err] - if {$r} { - tk_messageBox -icon error -title "Error" -message $err - } - if {![info exists widgetDemo]} { exit $r } -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/label.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/label.tcl @@ -1,40 +0,0 @@ -# label.tcl -- -# -# This demonstration script creates a toplevel window containing -# several label widgets. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .label -catch {destroy $w} -toplevel $w -wm title $w "Label Demonstration" -wm iconname $w "label" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "Five labels are displayed below: three textual ones on the left, and an image label and a text label on the right. Labels are pretty boring because you can't do anything with them." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -frame $w.left -frame $w.right -pack $w.left $w.right -side left -expand yes -padx 10 -pady 10 -fill both - -label $w.left.l1 -text "First label" -label $w.left.l2 -text "Second label, raised" -relief raised -label $w.left.l3 -text "Third label, sunken" -relief sunken -pack $w.left.l1 $w.left.l2 $w.left.l3 -side top -expand yes -pady 2 -anchor w - -# Main widget program sets variable tk_demoDirectory -image create photo label.ousterhout \ - -file [file join $tk_demoDirectory images ouster.png] -label $w.right.picture -borderwidth 2 -relief sunken -image label.ousterhout -label $w.right.caption -text "Tcl/Tk Creator" -pack $w.right.picture $w.right.caption -side top diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/labelframe.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/labelframe.tcl @@ -1,76 +0,0 @@ -# labelframe.tcl -- -# -# This demonstration script creates a toplevel window containing -# several labelframe widgets. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .labelframe -catch {destroy $w} -toplevel $w -wm title $w "Labelframe Demonstration" -wm iconname $w "labelframe" -positionWindow $w - -# Some information - -label $w.msg -font $font -wraplength 4i -justify left -text "Labelframes are\ - used to group related widgets together. The label may be either \ - plain text or another widget." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -# Demo area - -frame $w.f -pack $w.f -side bottom -fill both -expand 1 -set w $w.f - -# A group of radiobuttons in a labelframe - -labelframe $w.f -text "Value" -padx 2 -pady 2 -grid $w.f -row 0 -column 0 -pady 2m -padx 2m - -foreach value {1 2 3 4} { - radiobutton $w.f.b$value -text "This is value $value" \ - -variable lfdummy -value $value - pack $w.f.b$value -side top -fill x -pady 2 -} - - -# Using a label window to control a group of options. - -proc lfEnableButtons {w} { - foreach child [winfo children $w] { - if {$child == "$w.cb"} continue - if {$::lfdummy2} { - $child configure -state normal - } else { - $child configure -state disabled - } - } -} - -labelframe $w.f2 -pady 2 -padx 2 -checkbutton $w.f2.cb -text "Use this option." -variable lfdummy2 \ - -command "lfEnableButtons $w.f2" -padx 0 -$w.f2 configure -labelwidget $w.f2.cb -grid $w.f2 -row 0 -column 1 -pady 2m -padx 2m - -set t 0 -foreach str {Option1 Option2 Option3} { - checkbutton $w.f2.b$t -text $str - pack $w.f2.b$t -side top -fill x -pady 2 - incr t -} -lfEnableButtons $w.f2 - - -grid columnconfigure $w {0 1} -weight 1 diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/license.terms b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/license.terms @@ -1,40 +0,0 @@ -This software is copyrighted by the Regents of the University of -California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState -Corporation, Apple Inc. and other parties. 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. - -GOVERNMENT USE: If you are acquiring this software on behalf of the -U.S. government, the Government shall have only "Restricted Rights" -in the software and related documentation as defined in the Federal -Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you -are acquiring the software on behalf of the Department of Defense, the -software shall be classified as "Commercial Computer Software" and the -Government shall have only "Restricted Rights" as defined in Clause -252.227-7013 (b) (3) of DFARs. Notwithstanding the foregoing, the -authors grant the U.S. Government and others acting in its behalf -permission to use and distribute the software in accordance with the -terms specified in this license. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/mclist.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/mclist.tcl @@ -1,119 +0,0 @@ -# mclist.tcl -- -# -# This demonstration script creates a toplevel window containing a Ttk -# tree widget configured as a multi-column listbox. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .mclist -catch {destroy $w} -toplevel $w -wm title $w "Multi-Column List" -wm iconname $w "mclist" -positionWindow $w - -## Explanatory text -ttk::label $w.msg -font $font -wraplength 4i -justify left -anchor n -padding {10 2 10 6} -text "Ttk is the new Tk themed widget set. One of the widgets it includes is a tree widget, which can be configured to display multiple columns of informational data without displaying the tree itself. This is a simple way to build a listbox that has multiple columns. Clicking on the heading for a column will sort the data by that column. You can also change the width of the columns by dragging the boundary between them." -pack $w.msg -fill x - -## See Code / Dismiss -pack [addSeeDismiss $w.seeDismiss $w] -side bottom -fill x - -ttk::frame $w.container -ttk::treeview $w.tree -columns {country capital currency} -show headings \ - -yscroll "$w.vsb set" -xscroll "$w.hsb set" -ttk::scrollbar $w.vsb -orient vertical -command "$w.tree yview" -ttk::scrollbar $w.hsb -orient horizontal -command "$w.tree xview" -pack $w.container -fill both -expand 1 -grid $w.tree $w.vsb -in $w.container -sticky nsew -grid $w.hsb -in $w.container -sticky nsew -grid column $w.container 0 -weight 1 -grid row $w.container 0 -weight 1 - -image create photo upArrow -data { - R0lGODlhDgAOAJEAANnZ2YCAgPz8/P///yH5BAEAAAAALAAAAAAOAA4AAAImhI+ - py+1LIsJHiBAh+BgmiEAJQITgW6DgUQIAECH4JN8IPqYuNxUAOw==} -image create photo downArrow -data { - R0lGODlhDgAOAJEAANnZ2YCAgPz8/P///yH5BAEAAAAALAAAAAAOAA4AAAInhI+ - py+1I4ocQ/IgDEYIPgYJICUCE4F+YIBolEoKPEJKZmVJK6ZACADs=} -image create photo noArrow -height 14 -width 14 - -## The data we're going to insert -set data { - Argentina {Buenos Aires} ARS - Australia Canberra AUD - Brazil Brazilia BRL - Canada Ottawa CAD - China Beijing CNY - France Paris EUR - Germany Berlin EUR - India {New Delhi} INR - Italy Rome EUR - Japan Tokyo JPY - Mexico {Mexico City} MXN - Russia Moscow RUB - {South Africa} Pretoria ZAR - {United Kingdom} London GBP - {United States} {Washington, D.C.} USD -} - -## Code to insert the data nicely -set font [ttk::style lookup Heading -font] -foreach col {country capital currency} name {Country Capital Currency} { - $w.tree heading $col -text $name -image noArrow -anchor w \ - -command [list SortBy $w.tree $col 0] - $w.tree column $col -width [expr { - [font measure $font $name] + [image width noArrow] + 5 - }] -} -set font [ttk::style lookup Treeview -font] -foreach {country capital currency} $data { - $w.tree insert {} end -values [list $country $capital $currency] - foreach col {country capital currency} { - set len [font measure $font "[set $col] "] - if {[$w.tree column $col -width] < $len} { - $w.tree column $col -width $len - } - } -} - -## Code to do the sorting of the tree contents when clicked on -proc SortBy {tree col direction} { - # Determine currently sorted column and its sort direction - foreach c {country capital currency} { - set s [$tree heading $c state] - if {("selected" in $s || "alternate" in $s) && $col ne $c} { - # Sorted column has changed - $tree heading $c -image noArrow state {!selected !alternate !user1} - set direction [expr {"alternate" in $s}] - } - } - - # Build something we can sort - set data {} - foreach row [$tree children {}] { - lappend data [list [$tree set $row $col] $row] - } - - set dir [expr {$direction ? "-decreasing" : "-increasing"}] - set r -1 - - # Now reshuffle the rows into the sorted order - foreach info [lsort -dictionary -index 0 $dir $data] { - $tree move [lindex $info 1] {} [incr r] - } - - # Switch the heading so that it will sort in the opposite direction - $tree heading $col -command [list SortBy $tree $col [expr {!$direction}]] \ - state [expr {$direction?"!selected alternate":"selected !alternate"}] - if {[ttk::style theme use] eq "aqua"} { - # Aqua theme displays native sort arrows when user1 state is set - $tree heading $col state "user1" - } else { - $tree heading $col -image [expr {$direction?"upArrow":"downArrow"}] - } -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/menu.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/menu.tcl @@ -1,163 +0,0 @@ -# menu.tcl -- -# -# This demonstration script creates a window with a bunch of menus -# and cascaded menus using menubars. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .menu -catch {destroy $w} -toplevel $w -wm title $w "Menu Demonstration" -wm iconname $w "menu" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -if {[tk windowingsystem] eq "aqua"} { - catch {set origUseCustomMDEF $::tk::mac::useCustomMDEF; set ::tk::mac::useCustomMDEF 1} - $w.msg configure -text "This window has a menubar with cascaded menus. You can invoke entries with an accelerator by typing Command+x, where \"x\" is the character next to the command key symbol. The rightmost menu can be torn off into a palette by selecting the first item in the menu." -} else { - $w.msg configure -text "This window contains a menubar with cascaded menus. You can post a menu from the keyboard by typing Alt+x, where \"x\" is the character underlined on the menu. You can then traverse among the menus using the arrow keys. When a menu is posted, you can invoke the current entry by typing space, or you can invoke any entry by typing its underlined character. If a menu entry has an accelerator, you can invoke the entry without posting the menu just by typing the accelerator. The rightmost menu can be torn off into a palette by selecting the first item in the menu." -} -pack $w.msg -side top - -set menustatus " " -frame $w.statusBar -label $w.statusBar.label -textvariable menustatus -relief sunken -bd 1 -font "Helvetica 10" -anchor w -pack $w.statusBar.label -side left -padx 2 -expand yes -fill both -pack $w.statusBar -side bottom -fill x -pady 2 - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -menu $w.menu -tearoff 0 - -set m $w.menu.file -menu $m -tearoff 0 -$w.menu add cascade -label "File" -menu $m -underline 0 -$m add command -label "Open..." -command {error "this is just a demo: no action has been defined for the \"Open...\" entry"} -$m add command -label "New" -command {error "this is just a demo: no action has been defined for the \"New\" entry"} -$m add command -label "Save" -command {error "this is just a demo: no action has been defined for the \"Save\" entry"} -$m add command -label "Save As..." -command {error "this is just a demo: no action has been defined for the \"Save As...\" entry"} -$m add separator -$m add command -label "Print Setup..." -command {error "this is just a demo: no action has been defined for the \"Print Setup...\" entry"} -$m add command -label "Print..." -command {error "this is just a demo: no action has been defined for the \"Print...\" entry"} -$m add separator -$m add command -label "Dismiss Menus Demo" -command "destroy $w" - -set m $w.menu.basic -$w.menu add cascade -label "Basic" -menu $m -underline 0 -menu $m -tearoff 0 -$m add command -label "Long entry that does nothing" -if {[tk windowingsystem] eq "aqua"} { - set modifier Command -} elseif {[tk windowingsystem] == "win32"} { - set modifier Control -} else { - set modifier Meta -} -foreach i {A B C D E F} { - $m add command -label "Print letter \"$i\"" -underline 14 \ - -accelerator Meta+$i -command "puts $i" -accelerator $modifier+$i - bind $w <$modifier-[string tolower $i]> "puts $i" -} - -set m $w.menu.cascade -$w.menu add cascade -label "Cascades" -menu $m -underline 0 -menu $m -tearoff 0 -$m add command -label "Print hello" \ - -command {puts stdout "Hello"} -accelerator $modifier+H -underline 6 -bind $w <$modifier-h> {puts stdout "Hello"} -$m add command -label "Print goodbye" -command {\ - puts stdout "Goodbye"} -accelerator $modifier+G -underline 6 -bind $w <$modifier-g> {puts stdout "Goodbye"} -$m add cascade -label "Check buttons" \ - -menu $w.menu.cascade.check -underline 0 -$m add cascade -label "Radio buttons" \ - -menu $w.menu.cascade.radio -underline 0 - -set m $w.menu.cascade.check -menu $m -tearoff 0 -$m add check -label "Oil checked" -variable oil -$m add check -label "Transmission checked" -variable trans -$m add check -label "Brakes checked" -variable brakes -$m add check -label "Lights checked" -variable lights -$m add separator -$m add command -label "Show current values" \ - -command "showVars $w.menu.cascade.dialog oil trans brakes lights" -$m invoke 1 -$m invoke 3 - -set m $w.menu.cascade.radio -menu $m -tearoff 0 -$m add radio -label "10 point" -variable pointSize -value 10 -$m add radio -label "14 point" -variable pointSize -value 14 -$m add radio -label "18 point" -variable pointSize -value 18 -$m add radio -label "24 point" -variable pointSize -value 24 -$m add radio -label "32 point" -variable pointSize -value 32 -$m add sep -$m add radio -label "Roman" -variable style -value roman -$m add radio -label "Bold" -variable style -value bold -$m add radio -label "Italic" -variable style -value italic -$m add sep -$m add command -label "Show current values" \ - -command "showVars $w.menu.cascade.dialog pointSize style" -$m invoke 1 -$m invoke 7 - -set m $w.menu.icon -$w.menu add cascade -label "Icons" -menu $m -underline 0 -menu $m -tearoff 0 -# Main widget program sets variable tk_demoDirectory -image create photo lilearth -file [file join $tk_demoDirectory \ -images earthmenu.png] -$m add command -image lilearth \ - -hidemargin 1 -command [list \ - tk_dialog $w.pattern {Bitmap Menu Entry} \ - "The menu entry you invoked displays a photoimage rather than\ - a text string. Other than this, it is just like any other\ - menu entry." {} 0 OK ] -foreach i {info questhead error} { - $m add command -bitmap $i -hidemargin 1 -command [list \ - puts "You invoked the $i bitmap" ] -} -$m entryconfigure 2 -columnbreak 1 - -set m $w.menu.more -$w.menu add cascade -label "More" -menu $m -underline 0 -menu $m -tearoff 0 -foreach i {{An entry} {Another entry} {Does nothing} {Does almost nothing} {Make life meaningful}} { - $m add command -label $i -command [list puts "You invoked \"$i\""] -} -$m entryconfigure "Does almost nothing" -bitmap questhead -compound left \ - -command [list \ - tk_dialog $w.compound {Compound Menu Entry} \ - "The menu entry you invoked displays both a bitmap and a\ - text string. Other than this, it is just like any other\ - menu entry." {} 0 OK ] - -set m $w.menu.colors -$w.menu add cascade -label "Colors" -menu $m -underline 1 -menu $m -tearoff 1 -foreach i {red orange yellow green blue} { - $m add command -label $i -background $i -command [list \ - puts "You invoked \"$i\"" ] -} - -$w configure -menu $w.menu - -bind Menu <<MenuSelect>> { - global $menustatus - if {[catch {%W entrycget active -label} label]} { - set label " " - } - set menustatus $label - update idletasks -} - -if {[tk windowingsystem] eq "aqua"} {catch {set ::tk::mac::useCustomMDEF $origUseCustomMDEF}} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/menubu.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/menubu.tcl @@ -1,90 +0,0 @@ -# menubu.tcl -- -# -# This demonstration script creates a window with a bunch of menus -# and cascaded menus using menubuttons. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .menubu -catch {destroy $w} -toplevel $w -wm title $w "Menu Button Demonstration" -wm iconname $w "menubutton" -positionWindow $w - -frame $w.body -pack $w.body -expand 1 -fill both -if {[tk windowingsystem] eq "aqua"} {catch {set origUseCustomMDEF $::tk::mac::useCustomMDEF; set ::tk::mac::useCustomMDEF 1}} - -menubutton $w.body.below -text "Below" -underline 0 -direction below -menu $w.body.below.m -relief raised -menu $w.body.below.m -tearoff 0 -$w.body.below.m add command -label "Below menu: first item" -command "puts \"You have selected the first item from the Below menu.\"" -$w.body.below.m add command -label "Below menu: second item" -command "puts \"You have selected the second item from the Below menu.\"" -grid $w.body.below -row 0 -column 1 -sticky n -menubutton $w.body.right -text "Right" -underline 0 -direction right -menu $w.body.right.m -relief raised -menu $w.body.right.m -tearoff 0 -$w.body.right.m add command -label "Right menu: first item" -command "puts \"You have selected the first item from the Right menu.\"" -$w.body.right.m add command -label "Right menu: second item" -command "puts \"You have selected the second item from the Right menu.\"" -frame $w.body.center -menubutton $w.body.left -text "Left" -underline 0 -direction left -menu $w.body.left.m -relief raised -menu $w.body.left.m -tearoff 0 -$w.body.left.m add command -label "Left menu: first item" -command "puts \"You have selected the first item from the Left menu.\"" -$w.body.left.m add command -label "Left menu: second item" -command "puts \"You have selected the second item from the Left menu.\"" -grid $w.body.right -row 1 -column 0 -sticky w -grid $w.body.center -row 1 -column 1 -sticky news -grid $w.body.left -row 1 -column 2 -sticky e -menubutton $w.body.above -text "Above" -underline 0 -direction above -menu $w.body.above.m -relief raised -menu $w.body.above.m -tearoff 0 -$w.body.above.m add command -label "Above menu: first item" -command "puts \"You have selected the first item from the Above menu.\"" -$w.body.above.m add command -label "Above menu: second item" -command "puts \"You have selected the second item from the Above menu.\"" -grid $w.body.above -row 2 -column 1 -sticky s - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -set body $w.body.center -label $body.label -wraplength 300 -font "Helvetica 14" -justify left -text "This is a demonstration of menubuttons. The \"Below\" menubutton pops its menu below the button; the \"Right\" button pops to the right, etc. There are two option menus directly below this text; one is just a standard menu and the other is a 16-color palette." -pack $body.label -side top -padx 25 -pady 25 -frame $body.buttons -pack $body.buttons -padx 25 -pady 25 -tk_optionMenu $body.buttons.options menubuttonoptions one two three -pack $body.buttons.options -side left -padx 25 -pady 25 -set m [tk_optionMenu $body.buttons.colors paletteColor Black red4 DarkGreen NavyBlue gray75 Red Green Blue gray50 Yellow Cyan Magenta White Brown DarkSeaGreen DarkViolet] -if {[tk windowingsystem] eq "aqua"} { - set topBorderColor Black - set bottomBorderColor Black -} else { - set topBorderColor gray50 - set bottomBorderColor gray75 -} -for {set i 0} {$i <= [$m index last]} {incr i} { - set name [$m entrycget $i -label] - image create photo image_$name -height 16 -width 16 - image_$name put $topBorderColor -to 0 0 16 1 - image_$name put $topBorderColor -to 0 1 1 16 - image_$name put $bottomBorderColor -to 0 15 16 16 - image_$name put $bottomBorderColor -to 15 1 16 16 - image_$name put $name -to 1 1 15 15 - - image create photo image_${name}_s -height 16 -width 16 - image_${name}_s put Black -to 0 0 16 2 - image_${name}_s put Black -to 0 2 2 16 - image_${name}_s put Black -to 2 14 16 16 - image_${name}_s put Black -to 14 2 16 14 - image_${name}_s put $name -to 2 2 14 14 - - $m entryconfigure $i -image image_$name -selectimage image_${name}_s -hidemargin 1 -} -$m configure -tearoff 1 -foreach i {Black gray75 gray50 White} { - $m entryconfigure $i -columnbreak 1 -} - -pack $body.buttons.colors -side left -padx 25 -pady 25 - -if {[tk windowingsystem] eq "aqua"} {catch {set ::tk::mac::useCustomMDEF $origUseCustomMDEF}} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/msgbox.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/msgbox.tcl @@ -1,62 +0,0 @@ -# msgbox.tcl -- -# -# This demonstration script creates message boxes of various type - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .msgbox -catch {destroy $w} -toplevel $w -wm title $w "Message Box Demonstration" -wm iconname $w "messagebox" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "Choose the icon and type option of the message box. Then press the \"Message Box\" button to see the message box." -pack $w.msg -side top - -pack [addSeeDismiss $w.buttons $w {} { - ttk::button $w.buttons.vars -text "Message Box" -command "showMessageBox $w" -}] -side bottom -fill x -#pack $w.buttons.dismiss $w.buttons.code $w.buttons.vars -side left -expand 1 - -frame $w.left -frame $w.right -pack $w.left $w.right -side left -expand yes -fill y -pady .5c -padx .5c - -label $w.left.label -text "Icon" -frame $w.left.sep -relief ridge -bd 1 -height 2 -pack $w.left.label -side top -pack $w.left.sep -side top -fill x -expand no - -set msgboxIcon info -foreach i {error info question warning} { - radiobutton $w.left.b$i -text $i -variable msgboxIcon \ - -relief flat -value $i -width 16 -anchor w - pack $w.left.b$i -side top -pady 2 -anchor w -fill x -} - -label $w.right.label -text "Type" -frame $w.right.sep -relief ridge -bd 1 -height 2 -pack $w.right.label -side top -pack $w.right.sep -side top -fill x -expand no - -set msgboxType ok -foreach t {abortretryignore ok okcancel retrycancel yesno yesnocancel} { - radiobutton $w.right.$t -text $t -variable msgboxType \ - -relief flat -value $t -width 16 -anchor w - pack $w.right.$t -side top -pady 2 -anchor w -fill x -} - -proc showMessageBox {w} { - global msgboxIcon msgboxType - set button [tk_messageBox -icon $msgboxIcon -type $msgboxType \ - -title Message -parent $w\ - -message "This is a \"$msgboxType\" type messagebox with the \"$msgboxIcon\" icon"] - - tk_messageBox -icon info -message "You have selected \"$button\"" -type ok\ - -parent $w -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/nl.msg b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/nl.msg @@ -1,125 +0,0 @@ -::msgcat::mcset nl "Widget Demonstration" "Demonstratie van widgets" -::msgcat::mcset nl "tkWidgetDemo" "tkWidgetDemo" -::msgcat::mcset nl "&File" "&Bestand" -::msgcat::mcset nl "About..." "Info..." -::msgcat::mcset nl "&About..." "&Info..." -::msgcat::mcset nl "<F1>" "<F1>" -::msgcat::mcset nl "&Quit" "&Einde" -::msgcat::mcset nl "Meta+Q" "Meta+E" ;# Displayed hotkey -::msgcat::mcset nl "Meta-q" "Meta-e" ;# Actual binding sequence -::msgcat::mcset nl "Ctrl+Q" "Ctrl+E" ;# Displayed hotkey -::msgcat::mcset nl "Control-q" "Control-e" ;# Actual binding sequence -::msgcat::mcset nl "Dismiss" "Sluiten" -::msgcat::mcset nl "See Variables" "Bekijk Variabelen" -::msgcat::mcset nl "Variable Values" "Waarden Variabelen" -::msgcat::mcset nl "OK" "OK" -::msgcat::mcset nl "Run the \"%s\" sample program" "Start voorbeeld \"%s\"" -::msgcat::mcset nl "Print Code" "Code Afdrukken" -::msgcat::mcset nl "Demo code: %s" "Code van Demo %s" -::msgcat::mcset nl "About Widget Demo" "Over deze demonstratie" -::msgcat::mcset nl "Tk widget demonstration" "Demonstratie van Tk widgets" -::msgcat::mcset nl "Copyright © %s" - -::msgcat::mcset nl "Tk Widget Demonstrations" "Demonstratie van Tk widgets" -::msgcat::mcset nl "This application provides a front end for several short scripts" \ - "Dit programma is een schil rond enkele korte scripts waarmee" -::msgcat::mcset nl "that demonstrate what you can do with Tk widgets. Each of the" \ - "gedemonstreerd wordt wat je kunt doen met Tk widgets. Elk van de" -::msgcat::mcset nl "numbered lines below describes a demonstration; you can click on" \ - "genummerde regels hieronder omschrijft een demonstratie; je kunt de" -::msgcat::mcset nl "it to invoke the demonstration. Once the demonstration window" \ - "demonstratie starten door op de regel te klikken." -::msgcat::mcset nl "appears, you can click the" \ - "Zodra het nieuwe venster verschijnt, kun je op de knop" -::msgcat::mcset nl "See Code" "Bekijk Code" ;# This is also button text! -::msgcat::mcset nl "button to see the Tcl/Tk code that created the demonstration. If" \ - "drukken om de achterliggende Tcl/Tk code te zien. Als je dat wilt," -::msgcat::mcset nl "you wish, you can edit the code and click the" \ - "kun je de code wijzigen en op de knop" -::msgcat::mcset nl "Rerun Demo" "Herstart Demo" ;# This is also button text! -::msgcat::mcset nl "button in the code window to reinvoke the demonstration with the" \ - "drukken in het codevenster om de demonstratie uit te voeren met de" -::msgcat::mcset nl "modified code." \ - "nieuwe code." - -::msgcat::mcset nl "Labels, buttons, checkbuttons, and radiobuttons" \ - "Labels, knoppen, vinkjes/aankruishokjes en radioknoppen" - -::msgcat::mcset nl "Labels (text and bitmaps)" "Labels (tekst en plaatjes)" -::msgcat::mcset nl "Labels and UNICODE text" "Labels en tekst in UNICODE" -::msgcat::mcset nl "Buttons" "Buttons (drukknoppen)" -::msgcat::mcset nl "Check-buttons (select any of a group)" \ - "Check-buttons (een of meer uit een groep)" -::msgcat::mcset nl "Radio-buttons (select one of a group)" \ - "Radio-buttons (een van een groep)" -::msgcat::mcset nl "A 15-puzzle game made out of buttons" \ - "Een schuifpuzzel van buttons" -::msgcat::mcset nl "Iconic buttons that use bitmaps" \ - "Buttons met pictogrammen" -::msgcat::mcset nl "Two labels displaying images" \ - "Twee labels met plaatjes in plaats van tekst" -::msgcat::mcset nl "A simple user interface for viewing images" \ - "Een eenvoudige user-interface voor het bekijken van plaatjes" -::msgcat::mcset nl "Labelled frames" \ - "Kaders met bijschrift" - -::msgcat::mcset nl "Listboxes" "Keuzelijsten" -::msgcat::mcset nl "The 50 states" "De 50 staten van de VS" -::msgcat::mcset nl "Colors: change the color scheme for the application" \ - "Kleuren: verander het kleurenschema voor het programma" -::msgcat::mcset nl "A collection of famous and infamous sayings" \ - "Beroemde en beruchte citaten en gezegden" - -::msgcat::mcset nl "Entries and Spin-boxes" "Invulvelden en Spinboxen" -::msgcat::mcset nl "Entries without scrollbars" "Invulvelden zonder schuifbalk" -::msgcat::mcset nl "Entries with scrollbars" "Invulvelden met schuifbalk" -::msgcat::mcset nl "Validated entries and password fields" \ - "Invulvelden met controle of wachtwoorden" -::msgcat::mcset nl "Spin-boxes" "Spinboxen" -::msgcat::mcset nl "Simple Rolodex-like form" "Simpel kaartsysteem" - -::msgcat::mcset nl "Text" "Tekst" -::msgcat::mcset nl "Basic editable text" "Voorbeeld met te wijzigen tekst" -::msgcat::mcset nl "Text display styles" "Tekst met verschillende stijlen" -::msgcat::mcset nl "Hypertext (tag bindings)" \ - "Hypertext (verwijzingen via \"tags\")" -::msgcat::mcset nl "A text widget with embedded windows" \ - "Tekstwidget met windows erin" -::msgcat::mcset nl "A search tool built with a text widget" \ - "Zoeken in tekst met behulp van een tekstwidget" - -::msgcat::mcset nl "Canvases" "Canvaswidgets" -::msgcat::mcset nl "The canvas item types" "Objecten in een canvas" -::msgcat::mcset nl "A simple 2-D plot" "Eenvoudige 2D-grafiek" -::msgcat::mcset nl "Text items in canvases" "Tekstobjecten in een canvas" -::msgcat::mcset nl "An editor for arrowheads on canvas lines" \ - "Editor voor de vorm van de pijl (begin/eind van een lijn)" -::msgcat::mcset nl "A ruler with adjustable tab stops" \ - "Een meetlat met aanpasbare ruiters" -::msgcat::mcset nl "A building floor plan" "Plattegrond van een gebouw" -::msgcat::mcset nl "A simple scrollable canvas" "Een schuifbaar canvas" - -::msgcat::mcset nl "Scales" "Schaalverdelingen" -::msgcat::mcset nl "Horizontal scale" "Horizontale schaal" -::msgcat::mcset nl "Vertical scale" "Verticale schaal" - -::msgcat::mcset nl "Paned Windows" "Vensters opgedeeld in stukken" -::msgcat::mcset nl "Horizontal paned window" "Horizontaal gedeeld venster" -::msgcat::mcset nl "Vertical paned window" "Verticaal gedeeld venster" - -::msgcat::mcset nl "Menus" "Menu's" -::msgcat::mcset nl "Menus and cascades (sub-menus)" \ - "Menu's en cascades (submenu's)" -::msgcat::mcset nl "Menu-buttons" "Menu-buttons" - -::msgcat::mcset nl "Common Dialogs" "Veel voorkomende dialoogvensters" -::msgcat::mcset nl "Message boxes" "Mededeling (message box)" -::msgcat::mcset nl "File selection dialog" "Selectie van bestanden" -::msgcat::mcset nl "Color picker" "Kleurenpalet" - -::msgcat::mcset nl "Miscellaneous" "Diversen" -::msgcat::mcset nl "The built-in bitmaps" "Ingebouwde plaatjes" -::msgcat::mcset nl "A dialog box with a local grab" \ - "Een dialoogvenster met een locale \"grab\"" -::msgcat::mcset nl "A dialog box with a global grab" \ - "Een dialoogvenster met een globale \"grab\"" diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/paned1.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/paned1.tcl @@ -1,32 +0,0 @@ -# paned1.tcl -- -# -# This demonstration script creates a toplevel window containing -# a paned window that separates two windows horizontally. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .paned1 -catch {destroy $w} -toplevel $w -wm title $w "Horizontal Paned Window Demonstration" -wm iconname $w "paned1" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "The sash between the two coloured windows below can be used to divide the area between them. Use the left mouse button to resize without redrawing by just moving the sash, and use the middle mouse button to resize opaquely (always redrawing the windows in each position.)" -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -panedwindow $w.pane -pack $w.pane -side top -expand yes -fill both -pady 2 -padx 2m - -label $w.pane.left -text "This is the\nleft side" -bg yellow -label $w.pane.right -text "This is the\nright side" -bg cyan - -$w.pane add $w.pane.left $w.pane.right diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/paned2.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/paned2.tcl @@ -1,74 +0,0 @@ -# paned2.tcl -- -# -# This demonstration script creates a toplevel window containing -# a paned window that separates two windows vertically. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .paned2 -catch {destroy $w} -toplevel $w -wm title $w "Vertical Paned Window Demonstration" -wm iconname $w "paned2" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "The sash between the two scrolled windows below can be used to divide the area between them. Use the left mouse button to resize without redrawing by just moving the sash, and use the middle mouse button to resize opaquely (always redrawing the windows in each position.)" -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -# Create the pane itself -panedwindow $w.pane -orient vertical -pack $w.pane -side top -expand yes -fill both -pady 2 -padx 2m - -# The top window is a listbox with scrollbar -set paneList { - {List of Tk Widgets} - button - canvas - checkbutton - entry - frame - label - labelframe - listbox - menu - menubutton - message - panedwindow - radiobutton - scale - scrollbar - spinbox - text - toplevel -} -set f [frame $w.pane.top] -listbox $f.list -listvariable paneList -yscrollcommand "$f.scr set" -# Invert the first item to highlight it -$f.list itemconfigure 0 \ - -background [$f.list cget -fg] -foreground [$f.list cget -bg] -ttk::scrollbar $f.scr -orient vertical -command "$f.list yview" -pack $f.scr -side right -fill y -pack $f.list -fill both -expand 1 - -# The bottom window is a text widget with scrollbar -set f [frame $w.pane.bottom] -text $f.text -xscrollcommand "$f.xscr set" -yscrollcommand "$f.yscr set" \ - -width 30 -height 8 -wrap none -ttk::scrollbar $f.xscr -orient horizontal -command "$f.text xview" -ttk::scrollbar $f.yscr -orient vertical -command "$f.text yview" -grid $f.text $f.yscr -sticky nsew -grid $f.xscr -sticky nsew -grid columnconfigure $f 0 -weight 1 -grid rowconfigure $f 0 -weight 1 -$f.text insert 1.0 "This is just a normal text widget" - -# Now add our contents to the paned window -$w.pane add $w.pane.top $w.pane.bottom diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/pendulum.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/pendulum.tcl @@ -1,197 +0,0 @@ -# pendulum.tcl -- -# -# This demonstration illustrates how Tcl/Tk can be used to construct -# simulations of physical systems. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .pendulum -catch {destroy $w} -toplevel $w -wm title $w "Pendulum Animation Demonstration" -wm iconname $w "pendulum" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration shows how Tcl/Tk can be used to carry out animations that are linked to simulations of physical systems. In the left canvas is a graphical representation of the physical system itself, a simple pendulum, and in the right canvas is a graph of the phase space of the system, which is a plot of the angle (relative to the vertical) against the angular velocity. The pendulum bob may be repositioned by clicking and dragging anywhere on the left canvas." -pack $w.msg - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -# Create some structural widgets -pack [panedwindow $w.p] -fill both -expand 1 -$w.p add [labelframe $w.p.l1 -text "Pendulum Simulation"] -$w.p add [labelframe $w.p.l2 -text "Phase Space"] - -# Create the canvas containing the graphical representation of the -# simulated system. -canvas $w.c -width 320 -height 200 -background white -bd 2 -relief sunken -$w.c create text 5 5 -anchor nw -text "Click to Adjust Bob Start Position" -# Coordinates of these items don't matter; they will be set properly below -$w.c create line 0 25 320 25 -tags plate -fill grey50 -width 2 -$w.c create oval 155 20 165 30 -tags pivot -fill grey50 -outline {} -$w.c create line 1 1 1 1 -tags rod -fill black -width 3 -$w.c create oval 1 1 2 2 -tags bob -fill yellow -outline black -pack $w.c -in $w.p.l1 -fill both -expand true - -# Create the canvas containing the phase space graph; this consists of -# a line that gets gradually paler as it ages, which is an extremely -# effective visual trick. -canvas $w.k -width 320 -height 200 -background white -bd 2 -relief sunken -$w.k create line 160 200 160 0 -fill grey75 -arrow last -tags y_axis -$w.k create line 0 100 320 100 -fill grey75 -arrow last -tags x_axis -for {set i 90} {$i>=0} {incr i -10} { - # Coordinates of these items don't matter; they will be set properly below - $w.k create line 0 0 1 1 -smooth true -tags graph$i -fill grey$i -} - -$w.k create text 0 0 -anchor ne -text "\u03b8" -tags label_theta -$w.k create text 0 0 -anchor ne -text "\u03b4\u03b8" -tags label_dtheta -pack $w.k -in $w.p.l2 -fill both -expand true - -# Initialize some variables -set points {} -set Theta 45.0 -set dTheta 0.0 -set pi 3.1415926535897933 -set length 150 -set home 160 - -# This procedure makes the pendulum appear at the correct place on the -# canvas. If the additional arguments "at $x $y" are passed (the 'at' -# is really just syntactic sugar) instead of computing the position of -# the pendulum from the length of the pendulum rod and its angle, the -# length and angle are computed in reverse from the given location -# (which is taken to be the centre of the pendulum bob.) -proc showPendulum {canvas {at {}} {x {}} {y {}}} { - global Theta dTheta pi length home - if {$at eq "at" && ($x!=$home || $y!=25)} { - set dTheta 0.0 - set x2 [expr {$x - $home}] - set y2 [expr {$y - 25}] - set length [expr {hypot($x2, $y2)}] - set Theta [expr {atan2($x2, $y2) * 180/$pi}] - } else { - set angle [expr {$Theta * $pi/180}] - set x [expr {$home + $length*sin($angle)}] - set y [expr {25 + $length*cos($angle)}] - } - $canvas coords rod $home 25 $x $y - $canvas coords bob \ - [expr {$x-15}] [expr {$y-15}] [expr {$x+15}] [expr {$y+15}] -} -showPendulum $w.c - -# Update the phase-space graph according to the current angle and the -# rate at which the angle is changing (the first derivative with -# respect to time.) -proc showPhase {canvas} { - global Theta dTheta points psw psh - lappend points [expr {$Theta+$psw}] [expr {-20*$dTheta+$psh}] - if {[llength $points] > 100} { - set points [lrange $points end-99 end] - } - for {set i 0} {$i<100} {incr i 10} { - set list [lrange $points end-[expr {$i-1}] end-[expr {$i-12}]] - if {[llength $list] >= 4} { - $canvas coords graph$i $list - } - } -} - -# Set up some bindings on the canvases. Note that when the user -# clicks we stop the animation until they release the mouse -# button. Also note that both canvases are sensitive to <Configure> -# events, which allows them to find out when they have been resized by -# the user. -bind $w.c <Destroy> { - after cancel $animationCallbacks(pendulum) - unset animationCallbacks(pendulum) -} -bind $w.c <1> { - after cancel $animationCallbacks(pendulum) - showPendulum %W at %x %y -} -bind $w.c <B1-Motion> { - showPendulum %W at %x %y -} -bind $w.c <ButtonRelease-1> { - showPendulum %W at %x %y - set animationCallbacks(pendulum) [after 15 repeat [winfo toplevel %W]] -} -bind $w.c <Configure> { - %W coords plate 0 25 %w 25 - set home [expr %w/2] - %W coords pivot [expr $home-5] 20 [expr $home+5] 30 -} -bind $w.k <Configure> { - set psh [expr %h/2] - set psw [expr %w/2] - %W coords x_axis 2 $psh [expr %w-2] $psh - %W coords y_axis $psw [expr %h-2] $psw 2 - %W coords label_dtheta [expr $psw-4] 6 - %W coords label_theta [expr %w-6] [expr $psh+4] -} - -# This procedure is the "business" part of the simulation that does -# simple numerical integration of the formula for a simple rotational -# pendulum. -proc recomputeAngle {} { - global Theta dTheta pi length - set scaling [expr {3000.0/$length/$length}] - - # To estimate the integration accurately, we really need to - # compute the end-point of our time-step. But to do *that*, we - # need to estimate the integration accurately! So we try this - # technique, which is inaccurate, but better than doing it in a - # single step. What we really want is bound up in the - # differential equation: - # .. - sin theta - # theta + theta = ----------- - # length - # But my math skills are not good enough to solve this! - - # first estimate - set firstDDTheta [expr {-sin($Theta * $pi/180)*$scaling}] - set midDTheta [expr {$dTheta + $firstDDTheta}] - set midTheta [expr {$Theta + ($dTheta + $midDTheta)/2}] - # second estimate - set midDDTheta [expr {-sin($midTheta * $pi/180)*$scaling}] - set midDTheta [expr {$dTheta + ($firstDDTheta + $midDDTheta)/2}] - set midTheta [expr {$Theta + ($dTheta + $midDTheta)/2}] - # Now we do a double-estimate approach for getting the final value - # first estimate - set midDDTheta [expr {-sin($midTheta * $pi/180)*$scaling}] - set lastDTheta [expr {$midDTheta + $midDDTheta}] - set lastTheta [expr {$midTheta + ($midDTheta + $lastDTheta)/2}] - # second estimate - set lastDDTheta [expr {-sin($lastTheta * $pi/180)*$scaling}] - set lastDTheta [expr {$midDTheta + ($midDDTheta + $lastDDTheta)/2}] - set lastTheta [expr {$midTheta + ($midDTheta + $lastDTheta)/2}] - # Now put the values back in our globals - set dTheta $lastDTheta - set Theta $lastTheta -} - -# This method ties together the simulation engine and the graphical -# display code that visualizes it. -proc repeat w { - global animationCallbacks - - # Simulate - recomputeAngle - - # Update the display - showPendulum $w.c - showPhase $w.k - - # Reschedule ourselves - set animationCallbacks(pendulum) [after 15 [list repeat $w]] -} -# Start the simulation after a short pause -set animationCallbacks(pendulum) [after 500 [list repeat $w]] diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/plot.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/plot.tcl @@ -1,97 +0,0 @@ -# plot.tcl -- -# -# This demonstration script creates a canvas widget showing a 2-D -# plot with data points that can be dragged with the mouse. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .plot -catch {destroy $w} -toplevel $w -wm title $w "Plot Demonstration" -wm iconname $w "Plot" -positionWindow $w -set c $w.c - -label $w.msg -font $font -wraplength 4i -justify left -text "This window displays a canvas widget containing a simple 2-dimensional plot. You can doctor the data by dragging any of the points with mouse button 1." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -canvas $c -relief raised -width 450 -height 300 -pack $w.c -side top -fill x - -set plotFont {Helvetica 18} - -$c create line 100 250 400 250 -width 2 -$c create line 100 250 100 50 -width 2 -$c create text 225 20 -text "A Simple Plot" -font $plotFont -fill brown - -for {set i 0} {$i <= 10} {incr i} { - set x [expr {100 + ($i*30)}] - $c create line $x 250 $x 245 -width 2 - $c create text $x 254 -text [expr {10*$i}] -anchor n -font $plotFont -} -for {set i 0} {$i <= 5} {incr i} { - set y [expr {250 - ($i*40)}] - $c create line 100 $y 105 $y -width 2 - $c create text 96 $y -text [expr {$i*50}].0 -anchor e -font $plotFont -} - -foreach point { - {12 56} {20 94} {33 98} {32 120} {61 180} {75 160} {98 223} -} { - set x [expr {100 + (3*[lindex $point 0])}] - set y [expr {250 - (4*[lindex $point 1])/5}] - set item [$c create oval [expr {$x-6}] [expr {$y-6}] \ - [expr {$x+6}] [expr {$y+6}] -width 1 -outline black \ - -fill SkyBlue2] - $c addtag point withtag $item -} - -$c bind point <Any-Enter> "$c itemconfig current -fill red" -$c bind point <Any-Leave> "$c itemconfig current -fill SkyBlue2" -$c bind point <1> "plotDown $c %x %y" -$c bind point <ButtonRelease-1> "$c dtag selected" -bind $c <B1-Motion> "plotMove $c %x %y" - -set plot(lastX) 0 -set plot(lastY) 0 - -# plotDown -- -# This procedure is invoked when the mouse is pressed over one of the -# data points. It sets up state to allow the point to be dragged. -# -# Arguments: -# w - The canvas window. -# x, y - The coordinates of the mouse press. - -proc plotDown {w x y} { - global plot - $w dtag selected - $w addtag selected withtag current - $w raise current - set plot(lastX) $x - set plot(lastY) $y -} - -# plotMove -- -# This procedure is invoked during mouse motion events. It drags the -# current item. -# -# Arguments: -# w - The canvas window. -# x, y - The coordinates of the mouse. - -proc plotMove {w x y} { - global plot - $w move selected [expr {$x-$plot(lastX)}] [expr {$y-$plot(lastY)}] - set plot(lastX) $x - set plot(lastY) $y -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/puzzle.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/puzzle.tcl @@ -1,82 +0,0 @@ -# puzzle.tcl -- -# -# This demonstration script creates a 15-puzzle game using a collection -# of buttons. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -# puzzleSwitch -- -# This procedure is invoked when the user clicks on a particular button; -# if the button is next to the empty space, it moves the button into th -# empty space. - -proc puzzleSwitch {w num} { - global xpos ypos - if {(($ypos($num) >= ($ypos(space) - .01)) - && ($ypos($num) <= ($ypos(space) + .01)) - && ($xpos($num) >= ($xpos(space) - .26)) - && ($xpos($num) <= ($xpos(space) + .26))) - || (($xpos($num) >= ($xpos(space) - .01)) - && ($xpos($num) <= ($xpos(space) + .01)) - && ($ypos($num) >= ($ypos(space) - .26)) - && ($ypos($num) <= ($ypos(space) + .26)))} { - set tmp $xpos(space) - set xpos(space) $xpos($num) - set xpos($num) $tmp - set tmp $ypos(space) - set ypos(space) $ypos($num) - set ypos($num) $tmp - place $w.frame.$num -relx $xpos($num) -rely $ypos($num) - } -} - -set w .puzzle -catch {destroy $w} -toplevel $w -wm title $w "15-Puzzle Demonstration" -wm iconname $w "15-Puzzle" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "A 15-puzzle appears below as a collection of buttons. Click on any of the pieces next to the space, and that piece will slide over the space. Continue this until the pieces are arranged in numerical order from upper-left to lower-right." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -# Special trick: select a darker color for the space by creating a -# scrollbar widget and using its trough color. - -scrollbar $w.s - -# The button metrics are a bit bigger in Aqua, and since we are -# using place which doesn't autosize, then we need to have a -# slightly larger frame here... - -if {[tk windowingsystem] eq "aqua"} { - set frameSize 168 -} else { - set frameSize 120 -} - -frame $w.frame -width $frameSize -height $frameSize -borderwidth 2\ - -relief sunken -bg [$w.s cget -troughcolor] -pack $w.frame -side top -pady 1c -padx 1c -destroy $w.s - -set order {3 1 6 2 5 7 15 13 4 11 8 9 14 10 12} -for {set i 0} {$i < 15} {set i [expr {$i+1}]} { - set num [lindex $order $i] - set xpos($num) [expr {($i%4)*.25}] - set ypos($num) [expr {($i/4)*.25}] - button $w.frame.$num -relief raised -text $num -highlightthickness 0 \ - -command "puzzleSwitch $w $num" - place $w.frame.$num -relx $xpos($num) -rely $ypos($num) \ - -relwidth .25 -relheight .25 -} -set xpos(space) .75 -set ypos(space) .75 diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/radio.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/radio.tcl @@ -1,66 +0,0 @@ -# radio.tcl -- -# -# This demonstration script creates a toplevel window containing -# several radiobutton widgets. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .radio -catch {destroy $w} -toplevel $w -wm title $w "Radiobutton Demonstration" -wm iconname $w "radio" -positionWindow $w -label $w.msg -font $font -wraplength 5i -justify left -text "Three groups of radiobuttons are displayed below. If you click on a button then the button will become selected exclusively among all the buttons in its group. A Tcl variable is associated with each group to indicate which of the group's buttons is selected. When the 'Tristate' button is pressed, the radio buttons will display the tri-state mode. Selecting any radio button will return the buttons to their respective on/off state. Click the \"See Variables\" button to see the current values of the variables." -grid $w.msg -row 0 -column 0 -columnspan 3 -sticky nsew - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w [list size color align]] -grid $btns -row 3 -column 0 -columnspan 3 -sticky ew - -labelframe $w.left -pady 2 -text "Point Size" -padx 2 -labelframe $w.mid -pady 2 -text "Color" -padx 2 -labelframe $w.right -pady 2 -text "Alignment" -padx 2 -button $w.tristate -text Tristate -command "set size multi; set color multi" \ - -pady 2 -padx 2 -if {[tk windowingsystem] eq "aqua"} { - $w.tristate configure -padx 10 -} -grid $w.left -column 0 -row 1 -pady .5c -padx .5c -rowspan 2 -grid $w.mid -column 1 -row 1 -pady .5c -padx .5c -rowspan 2 -grid $w.right -column 2 -row 1 -pady .5c -padx .5c -grid $w.tristate -column 2 -row 2 -pady .5c -padx .5c - -foreach i {10 12 14 18 24} { - radiobutton $w.left.b$i -text "Point Size $i" -variable size \ - -relief flat -value $i -tristatevalue "multi" - pack $w.left.b$i -side top -pady 2 -anchor w -fill x -} - -foreach c {Red Green Blue Yellow Orange Purple} { - set lower [string tolower $c] - radiobutton $w.mid.$lower -text $c -variable color \ - -relief flat -value $lower -anchor w \ - -command "$w.mid configure -fg \$color" \ - -tristatevalue "multi" - pack $w.mid.$lower -side top -pady 2 -fill x -} - - -label $w.right.l -text "Label" -bitmap questhead -compound left -$w.right.l configure -width [winfo reqwidth $w.right.l] -compound top -$w.right.l configure -height [winfo reqheight $w.right.l] -foreach a {Top Left Right Bottom} { - set lower [string tolower $a] - radiobutton $w.right.$lower -text $a -variable align \ - -relief flat -value $lower -indicatoron 0 -width 7 \ - -command "$w.right.l configure -compound \$align" -} - -grid x $w.right.top -grid $w.right.left $w.right.l $w.right.right -grid x $w.right.bottom diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/rmt b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/rmt @@ -1,210 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish8.6 "$0" ${1+"$@"} - -# rmt -- -# This script implements a simple remote-control mechanism for -# Tk applications. It allows you to select an application and -# then type commands to that application. - -package require Tk - -wm title . "Tk Remote Controller" -wm iconname . "Tk Remote" -wm minsize . 1 1 - -# The global variable below keeps track of the remote application -# that we're sending to. If it's an empty string then we execute -# the commands locally. - -set app "local" - -# The global variable below keeps track of whether we're in the -# middle of executing a command entered via the text. - -set executing 0 - -# The global variable below keeps track of the last command executed, -# so it can be re-executed in response to !! commands. - -set lastCommand "" - -# Create menu bar. Arrange to recreate all the information in the -# applications sub-menu whenever it is cascaded to. - -. configure -menu [menu .menu] -menu .menu.file -menu .menu.file.apps -postcommand fillAppsMenu -.menu add cascade -label "File" -underline 0 -menu .menu.file -.menu.file add cascade -label "Select Application" -underline 0 \ - -menu .menu.file.apps -.menu.file add command -label "Quit" -command "destroy ." -underline 0 - -# Create text window and scrollbar. - -text .t -yscrollcommand ".s set" -setgrid true -scrollbar .s -command ".t yview" -grid .t .s -sticky nsew -grid rowconfigure . 0 -weight 1 -grid columnconfigure . 0 -weight 1 - -# Create a binding to forward commands to the target application, -# plus modify many of the built-in bindings so that only information -# in the current command can be deleted (can still set the cursor -# earlier in the text and select and insert; just can't delete). - -bindtags .t {.t Text . all} -bind .t <Return> { - .t mark set insert {end - 1c} - .t insert insert \n - invoke - break -} -bind .t <Delete> { - catch {.t tag remove sel sel.first promptEnd} - if {[.t tag nextrange sel 1.0 end] eq ""} { - if {[.t compare insert < promptEnd]} { - break - } - } -} -bind .t <BackSpace> { - catch {.t tag remove sel sel.first promptEnd} - if {[.t tag nextrange sel 1.0 end] eq ""} { - if {[.t compare insert <= promptEnd]} { - break - } - } -} -bind .t <Control-d> { - if {[.t compare insert < promptEnd]} { - break - } -} -bind .t <Control-k> { - if {[.t compare insert < promptEnd]} { - .t mark set insert promptEnd - } -} -bind .t <Control-t> { - if {[.t compare insert < promptEnd]} { - break - } -} -bind .t <Meta-d> { - if {[.t compare insert < promptEnd]} { - break - } -} -bind .t <Meta-BackSpace> { - if {[.t compare insert <= promptEnd]} { - break - } -} -bind .t <Control-h> { - if {[.t compare insert <= promptEnd]} { - break - } -} -### This next bit *isn't* nice - DKF ### -auto_load tk::TextInsert -proc tk::TextInsert {w s} { - if {$s eq ""} { - return - } - catch { - if { - [$w compare sel.first <= insert] && [$w compare sel.last >= insert] - } then { - $w tag remove sel sel.first promptEnd - $w delete sel.first sel.last - } - } - $w insert insert $s - $w see insert -} - -.t configure -font {Courier 12} -.t tag configure bold -font {Courier 12 bold} - -# The procedure below is used to print out a prompt at the -# insertion point (which should be at the beginning of a line -# right now). - -proc prompt {} { - global app - .t insert insert "$app: " - .t mark set promptEnd {insert} - .t mark gravity promptEnd left - .t tag add bold {promptEnd linestart} promptEnd -} - -# The procedure below executes a command (it takes everything on the -# current line after the prompt and either sends it to the remote -# application or executes it locally, depending on "app". - -proc invoke {} { - global app executing lastCommand - set cmd [.t get promptEnd insert] - incr executing 1 - if {[info complete $cmd]} { - if {$cmd eq "!!\n"} { - set cmd $lastCommand - } else { - set lastCommand $cmd - } - if {$app eq "local"} { - set result [catch [list uplevel #0 $cmd] msg] - } else { - set result [catch [list send $app $cmd] msg] - } - if {$result != 0} { - .t insert insert "Error: $msg\n" - } elseif {$msg ne ""} { - .t insert insert $msg\n - } - prompt - .t mark set promptEnd insert - } - incr executing -1 - .t yview -pickplace insert -} - -# The following procedure is invoked to change the application that -# we're talking to. It also updates the prompt for the current -# command, unless we're in the middle of executing a command from -# the text item (in which case a new prompt is about to be output -# so there's no need to change the old one). - -proc newApp appName { - global app executing - set app $appName - if {!$executing} { - .t mark gravity promptEnd right - .t delete "promptEnd linestart" promptEnd - .t insert promptEnd "$appName: " - .t tag add bold "promptEnd linestart" promptEnd - .t mark gravity promptEnd left - } - return -} - -# The procedure below will fill in the applications sub-menu with a list -# of all the applications that currently exist. - -proc fillAppsMenu {} { - set m .menu.file.apps - catch {$m delete 0 last} - foreach i [lsort [winfo interps]] { - $m add command -label $i -command [list newApp $i] - } - $m add command -label local -command {newApp local} -} - -set app [winfo name .] -prompt -focus .t - -# Local Variables: -# mode: tcl -# End: diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/rolodex b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/rolodex @@ -1,204 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish8.6 "$0" ${1+"$@"} - -# rolodex -- -# This script was written as an entry in Tom LaStrange's rolodex -# benchmark. It creates something that has some of the look and -# feel of a rolodex program, although it's lifeless and doesn't -# actually do the rolodex application. - -package require Tk - -foreach i [winfo child .] { - catch {destroy $i} -} - -set version 1.2 - -#------------------------------------------ -# Phase 0: create the front end. -#------------------------------------------ - -frame .frame -relief flat -pack .frame -side top -fill y -anchor center - -set names {{} Name: Address: {} {} {Home Phone:} {Work Phone:} Fax:} -foreach i {1 2 3 4 5 6 7} { - label .frame.label$i -text [lindex $names $i] -anchor e - entry .frame.entry$i -width 35 - grid .frame.label$i .frame.entry$i -sticky ew -pady 2 -padx 1 -} - -frame .buttons -pack .buttons -side bottom -pady 2 -anchor center -button .buttons.clear -text Clear -button .buttons.add -text Add -button .buttons.search -text Search -button .buttons.delete -text "Delete ..." -pack .buttons.clear .buttons.add .buttons.search .buttons.delete \ - -side left -padx 2 - -#------------------------------------------ -# Phase 1: Add menus, dialog boxes -#------------------------------------------ - -# DKF - note that this is an old-style menu bar; I just have not yet -# got around to converting the context help code to work with the new -# menu system and its <<MenuSelect>> virtual event. - -frame .menu -relief raised -borderwidth 1 -pack .menu -before .frame -side top -fill x - -menubutton .menu.file -text "File" -menu .menu.file.m -underline 0 -menu .menu.file.m -.menu.file.m add command -label "Load ..." -command fileAction -underline 0 -.menu.file.m add command -label "Exit" -command {destroy .} -underline 0 -pack .menu.file -side left - -menubutton .menu.help -text "Help" -menu .menu.help.m -underline 0 -menu .menu.help.m -pack .menu.help -side right - -proc deleteAction {} { - if {[tk_dialog .delete {Confirm Action} {Are you sure?} {} 0 Cancel] - == 0} { - clearAction - } -} -.buttons.delete config -command deleteAction - -proc fileAction {} { - tk_dialog .fileSelection {File Selection} {This is a dummy file selection dialog box, which is used because there isn't a good file selection dialog built into Tk yet.} {} 0 OK - puts stderr {dummy file name} -} - -#------------------------------------------ -# Phase 3: Print contents of card -#------------------------------------------ - -proc addAction {} { - global names - foreach i {1 2 3 4 5 6 7} { - puts stderr [format "%-12s %s" [lindex $names $i] [.frame.entry$i get]] - } -} -.buttons.add config -command addAction - -#------------------------------------------ -# Phase 4: Miscellaneous other actions -#------------------------------------------ - -proc clearAction {} { - foreach i {1 2 3 4 5 6 7} { - .frame.entry$i delete 0 end - } -} -.buttons.clear config -command clearAction - -proc fillCard {} { - clearAction - .frame.entry1 insert 0 "John Ousterhout" - .frame.entry2 insert 0 "CS Division, Department of EECS" - .frame.entry3 insert 0 "University of California" - .frame.entry4 insert 0 "Berkeley, CA 94720" - .frame.entry5 insert 0 "private" - .frame.entry6 insert 0 "510-642-0865" - .frame.entry7 insert 0 "510-642-5775" -} -.buttons.search config -command "addAction; fillCard" - -#---------------------------------------------------- -# Phase 5: Accelerators, mnemonics, command-line info -#---------------------------------------------------- - -.buttons.clear config -text "Clear Ctrl+C" -bind . <Control-c> clearAction -.buttons.add config -text "Add Ctrl+A" -bind . <Control-a> addAction -.buttons.search config -text "Search Ctrl+S" -bind . <Control-s> "addAction; fillCard" -.buttons.delete config -text "Delete... Ctrl+D" -bind . <Control-d> deleteAction - -.menu.file.m entryconfig 1 -accel Ctrl+F -bind . <Control-f> fileAction -.menu.file.m entryconfig 2 -accel Ctrl+Q -bind . <Control-q> {destroy .} - -focus .frame.entry1 - -#---------------------------------------------------- -# Phase 6: help -#---------------------------------------------------- - -proc Help {topic {x 0} {y 0}} { - global helpTopics helpCmds - if {$topic == ""} return - while {[info exists helpCmds($topic)]} { - set topic [eval $helpCmds($topic)] - } - if [info exists helpTopics($topic)] { - set msg $helpTopics($topic) - } else { - set msg "Sorry, but no help is available for this topic" - } - tk_dialog .help {Rolodex Help} "Information on $topic:\n\n$msg" \ - {} 0 OK -} - -proc getMenuTopic {w x y} { - return $w.[$w index @[expr {$y-[winfo rooty $w]}]] -} - -event add <<Help>> <F1> <Help> -bind . <<Help>> {Help [winfo containing %X %Y] %X %Y} -bind Menu <<Help>> {Help [winfo containing %X %Y] %X %Y} - -# Help text and commands follow: - -set helpTopics(.menu.file) {This is the "file" menu. It can be used to invoke some overall operations on the rolodex applications, such as loading a file or exiting.} - -set helpCmds(.menu.file.m) {getMenuTopic $topic $x $y} -set helpTopics(.menu.file.m.1) {The "Load" entry in the "File" menu posts a dialog box that you can use to select a rolodex file} -set helpTopics(.menu.file.m.2) {The "Exit" entry in the "File" menu causes the rolodex application to terminate} -set helpCmds(.menu.file.m.none) {set topic ".menu.file"} - -set helpTopics(.frame.entry1) {In this field of the rolodex entry you should type the person's name} -set helpTopics(.frame.entry2) {In this field of the rolodex entry you should type the first line of the person's address} -set helpTopics(.frame.entry3) {In this field of the rolodex entry you should type the second line of the person's address} -set helpTopics(.frame.entry4) {In this field of the rolodex entry you should type the third line of the person's address} -set helpTopics(.frame.entry5) {In this field of the rolodex entry you should type the person's home phone number, or "private" if the person doesn't want his or her number publicized} -set helpTopics(.frame.entry6) {In this field of the rolodex entry you should type the person's work phone number} -set helpTopics(.frame.entry7) {In this field of the rolodex entry you should type the phone number for the person's FAX machine} - -set helpCmds(.frame.label1) {set topic .frame.entry1} -set helpCmds(.frame.label2) {set topic .frame.entry2} -set helpCmds(.frame.label3) {set topic .frame.entry3} -set helpCmds(.frame.label4) {set topic .frame.entry4} -set helpCmds(.frame.label5) {set topic .frame.entry5} -set helpCmds(.frame.label6) {set topic .frame.entry6} -set helpCmds(.frame.label7) {set topic .frame.entry7} - -set helpTopics(context) {Unfortunately, this application doesn't support context-sensitive help in the usual way, because when this demo was written Tk didn't have a grab mechanism and this is needed for context-sensitive help. Instead, you can achieve much the same effect by simply moving the mouse over the window you're curious about and pressing the Help or F1 keys. You can do this anytime.} -set helpTopics(help) {This application provides only very crude help. Besides the entries in this menu, you can get help on individual windows by moving the mouse cursor over the window and pressing the Help or F1 keys.} -set helpTopics(window) {This window is a dummy rolodex application created as part of Tom LaStrange's toolkit benchmark. It doesn't really do anything useful except to demonstrate a few features of the Tk toolkit.} -set helpTopics(keys) "The following accelerator keys are defined for this application (in addition to those already available for the entry windows):\n\nCtrl+A:\t\tAdd\nCtrl+C:\t\tClear\nCtrl+D:\t\tDelete\nCtrl+F:\t\tEnter file name\nCtrl+Q:\t\tExit application (quit)\nCtrl+S:\t\tSearch (dummy operation)" -set helpTopics(version) "This is version $version." - -# Entries in "Help" menu - -.menu.help.m add command -label "On Context..." -command {Help context} \ - -underline 3 -.menu.help.m add command -label "On Help..." -command {Help help} \ - -underline 3 -.menu.help.m add command -label "On Window..." -command {Help window} \ - -underline 3 -.menu.help.m add command -label "On Keys..." -command {Help keys} \ - -underline 3 -.menu.help.m add command -label "On Version..." -command {Help version} \ - -underline 3 - -# Local Variables: -# mode: tcl -# End: diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/ruler.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/ruler.tcl @@ -1,171 +0,0 @@ -# ruler.tcl -- -# -# This demonstration script creates a canvas widget that displays a ruler -# with tab stops that can be set, moved, and deleted. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -# rulerMkTab -- -# This procedure creates a new triangular polygon in a canvas to -# represent a tab stop. -# -# Arguments: -# c - The canvas window. -# x, y - Coordinates at which to create the tab stop. - -proc rulerMkTab {c x y} { - upvar #0 demo_rulerInfo v - $c create polygon $x $y [expr {$x+$v(size)}] [expr {$y+$v(size)}] \ - [expr {$x-$v(size)}] [expr {$y+$v(size)}] -} - -set w .ruler -catch {destroy $w} -toplevel $w -wm title $w "Ruler Demonstration" -wm iconname $w "ruler" -positionWindow $w -set c $w.c - -label $w.msg -font $font -wraplength 5i -justify left -text "This canvas widget shows a mock-up of a ruler. You can create tab stops by dragging them out of the well to the right of the ruler. You can also drag existing tab stops. If you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -canvas $c -width 14.8c -height 2.5c -pack $w.c -side top -fill x - -set demo_rulerInfo(grid) .25c -set demo_rulerInfo(left) [winfo fpixels $c 1c] -set demo_rulerInfo(right) [winfo fpixels $c 13c] -set demo_rulerInfo(top) [winfo fpixels $c 1c] -set demo_rulerInfo(bottom) [winfo fpixels $c 1.5c] -set demo_rulerInfo(size) [winfo fpixels $c .2c] -set demo_rulerInfo(normalStyle) "-fill black" -# Main widget program sets variable tk_demoDirectory -if {[winfo depth $c] > 1} { - set demo_rulerInfo(activeStyle) "-fill red -stipple {}" - set demo_rulerInfo(deleteStyle) [list -fill red \ - -stipple @[file join $tk_demoDirectory images gray25.xbm]] -} else { - set demo_rulerInfo(activeStyle) "-fill black -stipple {}" - set demo_rulerInfo(deleteStyle) [list -fill black \ - -stipple @[file join $tk_demoDirectory images gray25.xbm]] -} - -$c create line 1c 0.5c 1c 1c 13c 1c 13c 0.5c -width 1 -for {set i 0} {$i < 12} {incr i} { - set x [expr {$i+1}] - $c create line ${x}c 1c ${x}c 0.6c -width 1 - $c create line $x.25c 1c $x.25c 0.8c -width 1 - $c create line $x.5c 1c $x.5c 0.7c -width 1 - $c create line $x.75c 1c $x.75c 0.8c -width 1 - $c create text $x.15c .75c -text $i -anchor sw -} -$c addtag well withtag [$c create rect 13.2c 1c 13.8c 0.5c \ - -outline black -fill [lindex [$c config -bg] 4]] -$c addtag well withtag [rulerMkTab $c [winfo pixels $c 13.5c] \ - [winfo pixels $c .65c]] - -$c bind well <1> "rulerNewTab $c %x %y" -$c bind tab <1> "rulerSelectTab $c %x %y" -bind $c <B1-Motion> "rulerMoveTab $c %x %y" -bind $c <Any-ButtonRelease-1> "rulerReleaseTab $c" - -# rulerNewTab -- -# Does all the work of creating a tab stop, including creating the -# triangle object and adding tags to it to give it tab behavior. -# -# Arguments: -# c - The canvas window. -# x, y - The coordinates of the tab stop. - -proc rulerNewTab {c x y} { - upvar #0 demo_rulerInfo v - $c addtag active withtag [rulerMkTab $c $x $y] - $c addtag tab withtag active - set v(x) $x - set v(y) $y - rulerMoveTab $c $x $y -} - -# rulerSelectTab -- -# This procedure is invoked when mouse button 1 is pressed over -# a tab. It remembers information about the tab so that it can -# be dragged interactively. -# -# Arguments: -# c - The canvas widget. -# x, y - The coordinates of the mouse (identifies the point by -# which the tab was picked up for dragging). - -proc rulerSelectTab {c x y} { - upvar #0 demo_rulerInfo v - set v(x) [$c canvasx $x $v(grid)] - set v(y) [expr {$v(top)+2}] - $c addtag active withtag current - eval "$c itemconf active $v(activeStyle)" - $c raise active -} - -# rulerMoveTab -- -# This procedure is invoked during mouse motion events to drag a tab. -# It adjusts the position of the tab, and changes its appearance if -# it is about to be dragged out of the ruler. -# -# Arguments: -# c - The canvas widget. -# x, y - The coordinates of the mouse. - -proc rulerMoveTab {c x y} { - upvar #0 demo_rulerInfo v - if {[$c find withtag active] == ""} { - return - } - set cx [$c canvasx $x $v(grid)] - set cy [$c canvasy $y] - if {$cx < $v(left)} { - set cx $v(left) - } - if {$cx > $v(right)} { - set cx $v(right) - } - if {($cy >= $v(top)) && ($cy <= $v(bottom))} { - set cy [expr {$v(top)+2}] - eval "$c itemconf active $v(activeStyle)" - } else { - set cy [expr {$cy-$v(size)-2}] - eval "$c itemconf active $v(deleteStyle)" - } - $c move active [expr {$cx-$v(x)}] [expr {$cy-$v(y)}] - set v(x) $cx - set v(y) $cy -} - -# rulerReleaseTab -- -# This procedure is invoked during button release events that end -# a tab drag operation. It deselects the tab and deletes the tab if -# it was dragged out of the ruler. -# -# Arguments: -# c - The canvas widget. -# x, y - The coordinates of the mouse. - -proc rulerReleaseTab c { - upvar #0 demo_rulerInfo v - if {[$c find withtag active] == {}} { - return - } - if {$v(y) != $v(top)+2} { - $c delete active - } else { - eval "$c itemconf active $v(normalStyle)" - $c dtag active - } -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/sayings.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/sayings.tcl @@ -1,44 +0,0 @@ -# sayings.tcl -- -# -# This demonstration script creates a listbox that can be scrolled -# both horizontally and vertically. It displays a collection of -# well-known sayings. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .sayings -catch {destroy $w} -toplevel $w -wm title $w "Listbox Demonstration (well-known sayings)" -wm iconname $w "sayings" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "The listbox below contains a collection of well-known sayings. You can scan the list using either of the scrollbars or by dragging in the listbox window with button 2 pressed." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -frame $w.frame -borderwidth 10 -pack $w.frame -side top -expand yes -fill both -padx 1c - - -ttk::scrollbar $w.frame.yscroll -command "$w.frame.list yview" -ttk::scrollbar $w.frame.xscroll -orient horizontal \ - -command "$w.frame.list xview" -listbox $w.frame.list -width 20 -height 10 -setgrid 1 \ - -yscroll "$w.frame.yscroll set" -xscroll "$w.frame.xscroll set" - -grid $w.frame.list -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news -grid $w.frame.yscroll -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news -grid $w.frame.xscroll -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news -grid rowconfig $w.frame 0 -weight 1 -minsize 0 -grid columnconfig $w.frame 0 -weight 1 -minsize 0 - - -$w.frame.list insert 0 "Don't speculate, measure" "Waste not, want not" "Early to bed and early to rise makes a man healthy, wealthy, and wise" "Ask not what your country can do for you, ask what you can do for your country" "I shall return" "NOT" "A picture is worth a thousand words" "User interfaces are hard to build" "Thou shalt not steal" "A penny for your thoughts" "Fool me once, shame on you; fool me twice, shame on me" "Every cloud has a silver lining" "Where there's smoke there's fire" "It takes one to know one" "Curiosity killed the cat" "Take this job and shove it" "Up a creek without a paddle" "I'm mad as hell and I'm not going to take it any more" "An apple a day keeps the doctor away" "Don't look a gift horse in the mouth" "Measure twice, cut once" diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/search.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/search.tcl @@ -1,139 +0,0 @@ -# search.tcl -- -# -# This demonstration script creates a collection of widgets that -# allow you to load a file into a text widget, then perform searches -# on that file. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -# textLoadFile -- -# This procedure below loads a file into a text widget, discarding -# the previous contents of the widget. Tags for the old widget are -# not affected, however. -# -# Arguments: -# w - The window into which to load the file. Must be a -# text widget. -# file - The name of the file to load. Must be readable. - -proc textLoadFile {w file} { - set f [open $file] - $w delete 1.0 end - while {![eof $f]} { - $w insert end [read $f 10000] - } - close $f -} - -# textSearch -- -# Search for all instances of a given string in a text widget and -# apply a given tag to each instance found. -# -# Arguments: -# w - The window in which to search. Must be a text widget. -# string - The string to search for. The search is done using -# exact matching only; no special characters. -# tag - Tag to apply to each instance of a matching string. - -proc textSearch {w string tag} { - $w tag remove search 0.0 end - if {$string == ""} { - return - } - set cur 1.0 - while 1 { - set cur [$w search -count length $string $cur end] - if {$cur == ""} { - break - } - $w tag add $tag $cur "$cur + $length char" - set cur [$w index "$cur + $length char"] - } -} - -# textToggle -- -# This procedure is invoked repeatedly to invoke two commands at -# periodic intervals. It normally reschedules itself after each -# execution but if an error occurs (e.g. because the window was -# deleted) then it doesn't reschedule itself. -# -# Arguments: -# cmd1 - Command to execute when procedure is called. -# sleep1 - Ms to sleep after executing cmd1 before executing cmd2. -# cmd2 - Command to execute in the *next* invocation of this -# procedure. -# sleep2 - Ms to sleep after executing cmd2 before executing cmd1 again. - -proc textToggle {cmd1 sleep1 cmd2 sleep2} { - catch { - eval $cmd1 - after $sleep1 [list textToggle $cmd2 $sleep2 $cmd1 $sleep1] - } -} - -set w .search -catch {destroy $w} -toplevel $w -wm title $w "Text Demonstration - Search and Highlight" -wm iconname $w "search" -positionWindow $w - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -frame $w.file -label $w.file.label -text "File name:" -width 13 -anchor w -entry $w.file.entry -width 40 -textvariable fileName -button $w.file.button -text "Load File" \ - -command "textLoadFile $w.text \$fileName" -pack $w.file.label $w.file.entry -side left -pack $w.file.button -side left -pady 5 -padx 10 -bind $w.file.entry <Return> " - textLoadFile $w.text \$fileName - focus $w.string.entry -" -focus $w.file.entry - -frame $w.string -label $w.string.label -text "Search string:" -width 13 -anchor w -entry $w.string.entry -width 40 -textvariable searchString -button $w.string.button -text "Highlight" \ - -command "textSearch $w.text \$searchString search" -pack $w.string.label $w.string.entry -side left -pack $w.string.button -side left -pady 5 -padx 10 -bind $w.string.entry <Return> "textSearch $w.text \$searchString search" - -text $w.text -yscrollcommand "$w.scroll set" -setgrid true -ttk::scrollbar $w.scroll -command "$w.text yview" -pack $w.file $w.string -side top -fill x -pack $w.scroll -side right -fill y -pack $w.text -expand yes -fill both - -# Set up display styles for text highlighting. - -if {[winfo depth $w] > 1} { - textToggle "$w.text tag configure search -background \ - #ce5555 -foreground white" 800 "$w.text tag configure \ - search -background {} -foreground {}" 200 -} else { - textToggle "$w.text tag configure search -background \ - black -foreground white" 800 "$w.text tag configure \ - search -background {} -foreground {}" 200 -} -$w.text insert 1.0 \ -{This window demonstrates how to use the tagging facilities in text -widgets to implement a searching mechanism. First, type a file name -in the top entry, then type <Return> or click on "Load File". Then -type a string in the lower entry and type <Return> or click on -"Load File". This will cause all of the instances of the string to -be tagged with the tag "search", and it will arrange for the tag's -display attributes to change to make all of the strings blink.} -$w.text mark set insert 0.0 - -set fileName "" -set searchString "" diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/spin.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/spin.tcl @@ -1,53 +0,0 @@ -# spin.tcl -- -# -# This demonstration script creates several spinbox widgets. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .spin -catch {destroy $w} -toplevel $w -wm title $w "Spinbox Demonstration" -wm iconname $w "spin" -positionWindow $w - -label $w.msg -font $font -wraplength 5i -justify left -text "Three different\ - spin-boxes are displayed below. You can add characters by pointing,\ - clicking and typing. The normal Motif editing characters are\ - supported, along with many Emacs bindings. For example, Backspace\ - and Control-h delete the character to the left of the insertion\ - cursor and Delete and Control-d delete the chararacter to the right\ - of the insertion cursor. For values that are too large to fit in the\ - window all at once, you can scan through the value by dragging with\ - mouse button2 pressed. Note that the first spin-box will only permit\ - you to type in integers, and the third selects from a list of\ - Australian cities." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -set australianCities { - Canberra Sydney Melbourne Perth Adelaide Brisbane - Hobart Darwin "Alice Springs" -} - -spinbox $w.s1 -from 1 -to 10 -width 10 -validate key \ - -vcmd {string is integer %P} -spinbox $w.s2 -from 0 -to 3 -increment .5 -format %05.2f -width 10 -spinbox $w.s3 -values $australianCities -width 10 - -#entry $w.e1 -#entry $w.e2 -#entry $w.e3 -pack $w.s1 $w.s2 $w.s3 -side top -pady 5 -padx 10 ;#-fill x - -#$w.e1 insert 0 "Initial value" -#$w.e2 insert end "This entry contains a long value, much too long " -#$w.e2 insert end "to fit in the window at one time, so long in fact " -#$w.e2 insert end "that you'll have to scan or scroll to see the end." diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/states.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/states.tcl @@ -1,54 +0,0 @@ -# states.tcl -- -# -# This demonstration script creates a listbox widget that displays -# the names of the 50 states in the United States of America. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .states -catch {destroy $w} -toplevel $w -wm title $w "Listbox Demonstration (50 states)" -wm iconname $w "states" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -justify left -text "A listbox containing the 50 states is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by scanning. To scan, press button 2 in the widget and drag up or down." -pack $w.msg -side top - -labelframe $w.justif -text Justification -foreach c {Left Center Right} { - set lower [string tolower $c] - radiobutton $w.justif.$lower -text $c -variable just \ - -relief flat -value $lower -anchor w \ - -command "$w.frame.list configure -justify \$just" \ - -tristatevalue "multi" - pack $w.justif.$lower -side left -pady 2 -fill x -} -pack $w.justif - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -frame $w.frame -borderwidth .5c -pack $w.frame -side top -expand yes -fill y - -ttk::scrollbar $w.frame.scroll -command "$w.frame.list yview" -listbox $w.frame.list -yscroll "$w.frame.scroll set" -setgrid 1 -height 12 -pack $w.frame.scroll -side right -fill y -pack $w.frame.list -side left -expand 1 -fill both - -$w.frame.list insert 0 Alabama Alaska Arizona Arkansas California \ - Colorado Connecticut Delaware Florida Georgia Hawaii Idaho Illinois \ - Indiana Iowa Kansas Kentucky Louisiana Maine Maryland \ - Massachusetts Michigan Minnesota Mississippi Missouri \ - Montana Nebraska Nevada "New Hampshire" "New Jersey" "New Mexico" \ - "New York" "North Carolina" "North Dakota" \ - Ohio Oklahoma Oregon Pennsylvania "Rhode Island" \ - "South Carolina" "South Dakota" \ - Tennessee Texas Utah Vermont Virginia Washington \ - "West Virginia" Wisconsin Wyoming diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/style.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/style.tcl @@ -1,155 +0,0 @@ -# style.tcl -- -# -# This demonstration script creates a text widget that illustrates the -# various display styles that may be set for tags. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .style -catch {destroy $w} -toplevel $w -wm title $w "Text Demonstration - Display Styles" -wm iconname $w "style" -positionWindow $w - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -# Only set the font family in one place for simplicity and consistency - -set family Courier - -text $w.text -yscrollcommand "$w.scroll set" -setgrid true \ - -width 70 -height 32 -wrap word -font "$family 12" -ttk::scrollbar $w.scroll -command "$w.text yview" -pack $w.scroll -side right -fill y -pack $w.text -expand yes -fill both - -# Set up display styles - -$w.text tag configure bold -font "$family 12 bold italic" -$w.text tag configure big -font "$family 14 bold" -$w.text tag configure verybig -font "Helvetica 24 bold" -$w.text tag configure tiny -font "Times 8 bold" -if {[winfo depth $w] > 1} { - $w.text tag configure color1 -background #a0b7ce - $w.text tag configure color2 -foreground red - $w.text tag configure raised -relief raised -borderwidth 1 - $w.text tag configure sunken -relief sunken -borderwidth 1 -} else { - $w.text tag configure color1 -background black -foreground white - $w.text tag configure color2 -background black -foreground white - $w.text tag configure raised -background white -relief raised \ - -borderwidth 1 - $w.text tag configure sunken -background white -relief sunken \ - -borderwidth 1 -} -$w.text tag configure bgstipple -background black -borderwidth 0 \ - -bgstipple gray12 -$w.text tag configure fgstipple -fgstipple gray50 -$w.text tag configure underline -underline on -$w.text tag configure overstrike -overstrike on -$w.text tag configure right -justify right -$w.text tag configure center -justify center -$w.text tag configure super -offset 4p -font "$family 10" -$w.text tag configure sub -offset -2p -font "$family 10" -$w.text tag configure margins -lmargin1 12m -lmargin2 6m -rmargin 10m -$w.text tag configure spacing -spacing1 10p -spacing2 2p \ - -lmargin1 12m -lmargin2 6m -rmargin 10m - -$w.text insert end {Text widgets like this one allow you to display information in a -variety of styles. Display styles are controlled using a mechanism -called } -$w.text insert end tags bold -$w.text insert end {. Tags are just textual names that you can apply to one -or more ranges of characters within a text widget. You can configure -tags with various display styles. If you do this, then the tagged -characters will be displayed with the styles you chose. The -available display styles are: -} -$w.text insert end "\n1. Font." big -$w.text insert end " You can choose any system font, " -$w.text insert end large verybig -$w.text insert end " or " -$w.text insert end "small" tiny ".\n" -$w.text insert end "\n2. Color." big -$w.text insert end " You can change either the " -$w.text insert end background color1 -$w.text insert end " or " -$w.text insert end foreground color2 -$w.text insert end "\ncolor, or " -$w.text insert end both {color1 color2} -$w.text insert end ".\n" -$w.text insert end "\n3. Stippling." big -$w.text insert end " You can cause either the " -$w.text insert end background bgstipple -$w.text insert end " or " -$w.text insert end foreground fgstipple -$w.text insert end { -information to be drawn with a stipple fill instead of a solid fill. -} -$w.text insert end "\n4. Underlining." big -$w.text insert end " You can " -$w.text insert end underline underline -$w.text insert end " ranges of text.\n" -$w.text insert end "\n5. Overstrikes." big -$w.text insert end " You can " -$w.text insert end "draw lines through" overstrike -$w.text insert end " ranges of text.\n" -$w.text insert end "\n6. 3-D effects." big -$w.text insert end { You can arrange for the background to be drawn -with a border that makes characters appear either } -$w.text insert end raised raised -$w.text insert end " or " -$w.text insert end sunken sunken -$w.text insert end ".\n" -$w.text insert end "\n7. Justification." big -$w.text insert end " You can arrange for lines to be displayed\n" -$w.text insert end "left-justified,\n" -$w.text insert end "right-justified, or\n" right -$w.text insert end "centered.\n" center -$w.text insert end "\n8. Superscripts and subscripts." big -$w.text insert end " You can control the vertical\n" -$w.text insert end "position of text to generate superscript effects like 10" -$w.text insert end "n" super -$w.text insert end " or\nsubscript effects like X" -$w.text insert end "i" sub -$w.text insert end ".\n" -$w.text insert end "\n9. Margins." big -$w.text insert end " You can control the amount of extra space left" -$w.text insert end " on\neach side of the text:\n" -$w.text insert end "This paragraph is an example of the use of " margins -$w.text insert end "margins. It consists of a single line of text " margins -$w.text insert end "that wraps around on the screen. There are two " margins -$w.text insert end "separate left margin values, one for the first " margins -$w.text insert end "display line associated with the text line, " margins -$w.text insert end "and one for the subsequent display lines, which " margins -$w.text insert end "occur because of wrapping. There is also a " margins -$w.text insert end "separate specification for the right margin, " margins -$w.text insert end "which is used to choose wrap points for lines.\n" margins -$w.text insert end "\n10. Spacing." big -$w.text insert end " You can control the spacing of lines with three\n" -$w.text insert end "separate parameters. \"Spacing1\" tells how much " -$w.text insert end "extra space to leave\nabove a line, \"spacing3\" " -$w.text insert end "tells how much space to leave below a line,\nand " -$w.text insert end "if a text line wraps, \"spacing2\" tells how much " -$w.text insert end "space to leave\nbetween the display lines that " -$w.text insert end "make up the text line.\n" -$w.text insert end "These indented paragraphs illustrate how spacing " spacing -$w.text insert end "can be used. Each paragraph is actually a " spacing -$w.text insert end "single line in the text widget, which is " spacing -$w.text insert end "word-wrapped by the widget.\n" spacing -$w.text insert end "Spacing1 is set to 10 points for this text, " spacing -$w.text insert end "which results in relatively large gaps between " spacing -$w.text insert end "the paragraphs. Spacing2 is set to 2 points, " spacing -$w.text insert end "which results in just a bit of extra space " spacing -$w.text insert end "within a pararaph. Spacing3 isn't used " spacing -$w.text insert end "in this example.\n" spacing -$w.text insert end "To see where the space is, select ranges of " spacing -$w.text insert end "text within these paragraphs. The selection " spacing -$w.text insert end "highlight will cover the extra space." spacing diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/tclIndex b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/tclIndex @@ -1,67 +0,0 @@ -# Tcl autoload index file, version 2.0 -# This file is generated by the "auto_mkindex" command -# and sourced to set up indexing information for one or -# more commands. Typically each line is a command that -# sets an element in the auto_index array, where the -# element name is the name of a command and the value is -# a script that loads the command. - -set auto_index(arrowSetup) [list source [file join $dir arrow.tcl]] -set auto_index(arrowMove1) [list source [file join $dir arrow.tcl]] -set auto_index(arrowMove2) [list source [file join $dir arrow.tcl]] -set auto_index(arrowMove3) [list source [file join $dir arrow.tcl]] -set auto_index(textLoadFile) [list source [file join $dir search.tcl]] -set auto_index(textSearch) [list source [file join $dir search.tcl]] -set auto_index(textToggle) [list source [file join $dir search.tcl]] -set auto_index(itemEnter) [list source [file join $dir items.tcl]] -set auto_index(itemLeave) [list source [file join $dir items.tcl]] -set auto_index(itemMark) [list source [file join $dir items.tcl]] -set auto_index(itemStroke) [list source [file join $dir items.tcl]] -set auto_index(itemsUnderArea) [list source [file join $dir items.tcl]] -set auto_index(itemStartDrag) [list source [file join $dir items.tcl]] -set auto_index(itemDrag) [list source [file join $dir items.tcl]] -set auto_index(butPress) [list source [file join $dir items.tcl]] -set auto_index(loadDir) [list source [file join $dir image2.tcl]] -set auto_index(loadImage) [list source [file join $dir image2.tcl]] -set auto_index(rulerMkTab) [list source [file join $dir ruler.tcl]] -set auto_index(rulerNewTab) [list source [file join $dir ruler.tcl]] -set auto_index(rulerSelectTab) [list source [file join $dir ruler.tcl]] -set auto_index(rulerMoveTab) [list source [file join $dir ruler.tcl]] -set auto_index(rulerReleaseTab) [list source [file join $dir ruler.tcl]] -set auto_index(mkTextConfig) [list source [file join $dir ctext.tcl]] -set auto_index(textEnter) [list source [file join $dir ctext.tcl]] -set auto_index(textInsert) [list source [file join $dir ctext.tcl]] -set auto_index(textPaste) [list source [file join $dir ctext.tcl]] -set auto_index(textB1Press) [list source [file join $dir ctext.tcl]] -set auto_index(textB1Move) [list source [file join $dir ctext.tcl]] -set auto_index(textBs) [list source [file join $dir ctext.tcl]] -set auto_index(textDel) [list source [file join $dir ctext.tcl]] -set auto_index(bitmapRow) [list source [file join $dir bitmap.tcl]] -set auto_index(scrollEnter) [list source [file join $dir cscroll.tcl]] -set auto_index(scrollLeave) [list source [file join $dir cscroll.tcl]] -set auto_index(scrollButton) [list source [file join $dir cscroll.tcl]] -set auto_index(textWindOn) [list source [file join $dir twind.tcl]] -set auto_index(textWindOff) [list source [file join $dir twind.tcl]] -set auto_index(textWindPlot) [list source [file join $dir twind.tcl]] -set auto_index(embPlotDown) [list source [file join $dir twind.tcl]] -set auto_index(embPlotMove) [list source [file join $dir twind.tcl]] -set auto_index(textWindDel) [list source [file join $dir twind.tcl]] -set auto_index(embDefBg) [list source [file join $dir twind.tcl]] -set auto_index(floorDisplay) [list source [file join $dir floor.tcl]] -set auto_index(newRoom) [list source [file join $dir floor.tcl]] -set auto_index(roomChanged) [list source [file join $dir floor.tcl]] -set auto_index(bg1) [list source [file join $dir floor.tcl]] -set auto_index(bg2) [list source [file join $dir floor.tcl]] -set auto_index(bg3) [list source [file join $dir floor.tcl]] -set auto_index(fg1) [list source [file join $dir floor.tcl]] -set auto_index(fg2) [list source [file join $dir floor.tcl]] -set auto_index(fg3) [list source [file join $dir floor.tcl]] -set auto_index(setWidth) [list source [file join $dir hscale.tcl]] -set auto_index(plotDown) [list source [file join $dir plot.tcl]] -set auto_index(plotMove) [list source [file join $dir plot.tcl]] -set auto_index(puzzleSwitch) [list source [file join $dir puzzle.tcl]] -set auto_index(setHeight) [list source [file join $dir vscale.tcl]] -set auto_index(showMessageBox) [list source [file join $dir msgbox.tcl]] -set auto_index(setColor) [list source [file join $dir clrpick.tcl]] -set auto_index(setColor_helper) [list source [file join $dir clrpick.tcl]] -set auto_index(fileDialog) [list source [file join $dir filebox.tcl]] diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/tcolor b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/tcolor @@ -1,358 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish8.6 "$0" ${1+"$@"} - -# tcolor -- -# This script implements a simple color editor, where you can -# create colors using either the RGB, HSB, or CYM color spaces -# and apply the color to existing applications. - -package require Tk 8.4 -wm title . "Color Editor" - -# Global variables that control the program: -# -# colorSpace - Color space currently being used for -# editing. Must be "rgb", "cmy", or "hsb". -# label1, label2, label3 - Labels for the scales. -# red, green, blue - Current color intensities in decimal -# on a scale of 0-65535. -# color - A string giving the current color value -# in the proper form for x: -# #RRRRGGGGBBBB -# updating - Non-zero means that we're in the middle of -# updating the scales to load a new color,so -# information shouldn't be propagating back -# from the scales to other elements of the -# program: this would make an infinite loop. -# command - Holds the command that has been typed -# into the "Command" entry. -# autoUpdate - 1 means execute the update command -# automatically whenever the color changes. -# name - Name for new color, typed into entry. - -set colorSpace hsb -set red 65535 -set green 0 -set blue 0 -set color #ffff00000000 -set updating 0 -set autoUpdate 1 -set name "" - -# Create the menu bar at the top of the window. - -. configure -menu [menu .menu] -menu .menu.file -.menu add cascade -menu .menu.file -label File -underline 0 -.menu.file add radio -label "RGB color space" -variable colorSpace \ - -value rgb -underline 0 -command {changeColorSpace rgb} -.menu.file add radio -label "CMY color space" -variable colorSpace \ - -value cmy -underline 0 -command {changeColorSpace cmy} -.menu.file add radio -label "HSB color space" -variable colorSpace \ - -value hsb -underline 0 -command {changeColorSpace hsb} -.menu.file add separator -.menu.file add radio -label "Automatic updates" -variable autoUpdate \ - -value 1 -underline 0 -.menu.file add radio -label "Manual updates" -variable autoUpdate \ - -value 0 -underline 0 -.menu.file add separator -.menu.file add command -label "Exit program" -underline 0 -command {exit} - -# Create the command entry window at the bottom of the window, along -# with the update button. - -labelframe .command -text "Command:" -padx {1m 0} -entry .command.e -textvariable command -button .command.update -text Update -command doUpdate -pack .command.update -side right -pady .1c -padx {.25c 0} -pack .command.e -expand yes -fill x -ipadx 0.25c - - -# Create the listbox that holds all of the color names in rgb.txt, -# if an rgb.txt file can be found. - -grid .command -sticky nsew -row 2 -columnspan 3 -padx 1m -pady {0 1m} - -grid columnconfigure . {1 2} -weight 1 -grid rowconfigure . 0 -weight 1 -foreach i { - /usr/local/lib/X11/rgb.txt /usr/lib/X11/rgb.txt - /X11/R5/lib/X11/rgb.txt /X11/R4/lib/rgb/rgb.txt - /usr/openwin/lib/X11/rgb.txt -} { - if {![file readable $i]} { - continue; - } - set f [open $i] - labelframe .names -text "Select:" -padx .1c -pady .1c - grid .names -row 0 -column 0 -sticky nsew -padx .15c -pady .15c -rowspan 2 - grid columnconfigure . 0 -weight 1 - listbox .names.lb -width 20 -height 12 -yscrollcommand ".names.s set" \ - -exportselection false - bind .names.lb <Double-1> { - tc_loadNamedColor [.names.lb get [.names.lb curselection]] - } - scrollbar .names.s -orient vertical -command ".names.lb yview" - pack .names.lb .names.s -side left -fill y -expand 1 - while {[gets $f line] >= 0} { - if {[regexp {^\s*\d+\s+\d+\s+\d+\s+(\S+)$} $line -> col]} { - .names.lb insert end $col - } - } - close $f - break -} - -# Create the three scales for editing the color, and the entry for -# typing in a color value. - -frame .adjust -foreach i {1 2 3} { - label .adjust.l$i -textvariable label$i -pady 0 - labelframe .adjust.$i -labelwidget .adjust.l$i -padx 1m -pady 1m - scale .scale$i -from 0 -to 1000 -length 6c -orient horizontal \ - -command tc_scaleChanged - pack .scale$i -in .adjust.$i - pack .adjust.$i -} -grid .adjust -row 0 -column 1 -sticky nsew -padx .15c -pady .15c - -labelframe .name -text "Name:" -padx 1m -pady 1m -entry .name.e -textvariable name -width 10 -pack .name.e -side right -expand 1 -fill x -bind .name.e <Return> {tc_loadNamedColor $name} -grid .name -column 1 -row 1 -sticky nsew -padx .15c -pady .15c - -# Create the color display swatch on the right side of the window. - -labelframe .sample -text "Color:" -padx 1m -pady 1m -frame .sample.swatch -width 2c -height 5c -background $color -label .sample.value -textvariable color -width 13 -font {Courier 12} -pack .sample.swatch -side top -expand yes -fill both -pack .sample.value -side bottom -pady .25c -grid .sample -row 0 -column 2 -sticky nsew -padx .15c -pady .15c -rowspan 2 - - -# The procedure below is invoked when one of the scales is adjusted. -# It propagates color information from the current scale readings -# to everywhere else that it is used. - -proc tc_scaleChanged args { - global red green blue colorSpace color updating autoUpdate - if {$updating} { - return - } - switch $colorSpace { - rgb { - set red [format %.0f [expr {[.scale1 get]*65.535}]] - set green [format %.0f [expr {[.scale2 get]*65.535}]] - set blue [format %.0f [expr {[.scale3 get]*65.535}]] - } - cmy { - set red [format %.0f [expr {65535 - [.scale1 get]*65.535}]] - set green [format %.0f [expr {65535 - [.scale2 get]*65.535}]] - set blue [format %.0f [expr {65535 - [.scale3 get]*65.535}]] - } - hsb { - set list [hsbToRgb [expr {[.scale1 get]/1000.0}] \ - [expr {[.scale2 get]/1000.0}] \ - [expr {[.scale3 get]/1000.0}]] - set red [lindex $list 0] - set green [lindex $list 1] - set blue [lindex $list 2] - } - } - set color [format "#%04x%04x%04x" $red $green $blue] - .sample.swatch config -bg $color - if {$autoUpdate} doUpdate - update idletasks -} - -# The procedure below is invoked to update the scales from the -# current red, green, and blue intensities. It's invoked after -# a change in the color space and after a named color value has -# been loaded. - -proc tc_setScales {} { - global red green blue colorSpace updating - set updating 1 - switch $colorSpace { - rgb { - .scale1 set [format %.0f [expr {$red/65.535}]] - .scale2 set [format %.0f [expr {$green/65.535}]] - .scale3 set [format %.0f [expr {$blue/65.535}]] - } - cmy { - .scale1 set [format %.0f [expr {(65535-$red)/65.535}]] - .scale2 set [format %.0f [expr {(65535-$green)/65.535}]] - .scale3 set [format %.0f [expr {(65535-$blue)/65.535}]] - } - hsb { - set list [rgbToHsv $red $green $blue] - .scale1 set [format %.0f [expr {[lindex $list 0] * 1000.0}]] - .scale2 set [format %.0f [expr {[lindex $list 1] * 1000.0}]] - .scale3 set [format %.0f [expr {[lindex $list 2] * 1000.0}]] - } - } - set updating 0 -} - -# The procedure below is invoked when a named color has been -# selected from the listbox or typed into the entry. It loads -# the color into the editor. - -proc tc_loadNamedColor name { - global red green blue color autoUpdate - - if {[string index $name 0] != "#"} { - set list [winfo rgb .sample.swatch $name] - set red [lindex $list 0] - set green [lindex $list 1] - set blue [lindex $list 2] - } else { - switch [string length $name] { - 4 {set format "#%1x%1x%1x"; set shift 12} - 7 {set format "#%2x%2x%2x"; set shift 8} - 10 {set format "#%3x%3x%3x"; set shift 4} - 13 {set format "#%4x%4x%4x"; set shift 0} - default {error "syntax error in color name \"$name\""} - } - if {[scan $name $format red green blue] != 3} { - error "syntax error in color name \"$name\"" - } - set red [expr {$red<<$shift}] - set green [expr {$green<<$shift}] - set blue [expr {$blue<<$shift}] - } - tc_setScales - set color [format "#%04x%04x%04x" $red $green $blue] - .sample.swatch config -bg $color - if {$autoUpdate} doUpdate -} - -# The procedure below is invoked when a new color space is selected. -# It changes the labels on the scales and re-loads the scales with -# the appropriate values for the current color in the new color space - -proc changeColorSpace space { - global label1 label2 label3 - switch $space { - rgb { - set label1 "Adjust Red:" - set label2 "Adjust Green:" - set label3 "Adjust Blue:" - tc_setScales - return - } - cmy { - set label1 "Adjust Cyan:" - set label2 "Adjust Magenta:" - set label3 "Adjust Yellow:" - tc_setScales - return - } - hsb { - set label1 "Adjust Hue:" - set label2 "Adjust Saturation:" - set label3 "Adjust Brightness:" - tc_setScales - return - } - } -} - -# The procedure below converts an RGB value to HSB. It takes red, green, -# and blue components (0-65535) as arguments, and returns a list containing -# HSB components (floating-point, 0-1) as result. The code here is a copy -# of the code on page 615 of "Fundamentals of Interactive Computer Graphics" -# by Foley and Van Dam. - -proc rgbToHsv {red green blue} { - if {$red > $green} { - set max [expr {double($red)}] - set min [expr {double($green)}] - } else { - set max [expr {double($green)}] - set min [expr {double($red)}] - } - if {$blue > $max} { - set max [expr {double($blue)}] - } elseif {$blue < $min} { - set min [expr {double($blue)}] - } - set range [expr {$max-$min}] - if {$max == 0} { - set sat 0 - } else { - set sat [expr {($max-$min)/$max}] - } - if {$sat == 0} { - set hue 0 - } else { - set rc [expr {($max - $red)/$range}] - set gc [expr {($max - $green)/$range}] - set bc [expr {($max - $blue)/$range}] - if {$red == $max} { - set hue [expr {($bc - $gc)/6.0}] - } elseif {$green == $max} { - set hue [expr {(2 + $rc - $bc)/6.0}] - } else { - set hue [expr {(4 + $gc - $rc)/6.0}] - } - if {$hue < 0.0} { - set hue [expr {$hue + 1.0}] - } - } - return [list $hue $sat [expr {$max/65535}]] -} - -# The procedure below converts an HSB value to RGB. It takes hue, saturation, -# and value components (floating-point, 0-1.0) as arguments, and returns a -# list containing RGB components (integers, 0-65535) as result. The code -# here is a copy of the code on page 616 of "Fundamentals of Interactive -# Computer Graphics" by Foley and Van Dam. - -proc hsbToRgb {hue sat value} { - set v [format %.0f [expr {65535.0*$value}]] - if {$sat == 0} { - return "$v $v $v" - } else { - set hue [expr {$hue*6.0}] - if {$hue >= 6.0} { - set hue 0.0 - } - scan $hue. %d i - set f [expr {$hue-$i}] - set p [format %.0f [expr {65535.0*$value*(1 - $sat)}]] - set q [format %.0f [expr {65535.0*$value*(1 - ($sat*$f))}]] - set t [format %.0f [expr {65535.0*$value*(1 - ($sat*(1 - $f)))}]] - switch $i { - 0 {return "$v $t $p"} - 1 {return "$q $v $p"} - 2 {return "$p $v $t"} - 3 {return "$p $q $v"} - 4 {return "$t $p $v"} - 5 {return "$v $p $q"} - default {error "i value $i is out of range"} - } - } -} - -# The procedure below is invoked when the "Update" button is pressed, -# and whenever the color changes if update mode is enabled. It -# propagates color information as determined by the command in the -# Command entry. - -proc doUpdate {} { - global color command - set newCmd $command - regsub -all %% $command $color newCmd - eval $newCmd -} - -changeColorSpace hsb - -# Local Variables: -# mode: tcl -# End: diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/text.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/text.tcl @@ -1,111 +0,0 @@ -# text.tcl -- -# -# This demonstration script creates a text widget that describes -# the basic editing functions. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .text -catch {destroy $w} -toplevel $w -wm title $w "Text Demonstration - Basic Facilities" -wm iconname $w "text" -positionWindow $w - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w {} \ - {ttk::button $w.buttons.fontchooser -command fontchooserToggle}] -pack $btns -side bottom -fill x - -text $w.text -yscrollcommand [list $w.scroll set] -setgrid 1 \ - -height 30 -undo 1 -autosep 1 -ttk::scrollbar $w.scroll -command [list $w.text yview] -pack $w.scroll -side right -fill y -pack $w.text -expand yes -fill both - -# TIP 324 Demo: [tk fontchooser] -proc fontchooserToggle {} { - tk fontchooser [expr {[tk fontchooser configure -visible] ? - "hide" : "show"}] -} -proc fontchooserVisibility {w} { - $w configure -text [expr {[tk fontchooser configure -visible] ? - "Hide Font Dialog" : "Show Font Dialog"}] -} -proc fontchooserFocus {w} { - tk fontchooser configure -font [$w cget -font] \ - -command [list fontchooserFontSel $w] -} -proc fontchooserFontSel {w font args} { - $w configure -font [font actual $font] -} -tk fontchooser configure -parent $w -bind $w.text <FocusIn> [list fontchooserFocus $w.text] -fontchooserVisibility $w.buttons.fontchooser -bind $w <<TkFontchooserVisibility>> [list \ - fontchooserVisibility $w.buttons.fontchooser] -focus $w.text - -$w.text insert 0.0 \ -{This window is a text widget. It displays one or more lines of text -and allows you to edit the text. Here is a summary of the things you -can do to a text widget: - -1. Scrolling. Use the scrollbar to adjust the view in the text window. - -2. Scanning. Press mouse button 2 in the text window and drag up or down. -This will drag the text at high speed to allow you to scan its contents. - -3. Insert text. Press mouse button 1 to set the insertion cursor, then -type text. What you type will be added to the widget. - -4. Select. Press mouse button 1 and drag to select a range of characters. -Once you've released the button, you can adjust the selection by pressing -button 1 with the shift key down. This will reset the end of the -selection nearest the mouse cursor and you can drag that end of the -selection by dragging the mouse before releasing the mouse button. -You can double-click to select whole words or triple-click to select -whole lines. - -5. Delete and replace. To delete text, select the characters you'd like -to delete and type Backspace or Delete. Alternatively, you can type new -text, in which case it will replace the selected text. - -6. Copy the selection. To copy the selection into this window, select -what you want to copy (either here or in another application), then -click button 2 to copy the selection to the point of the mouse cursor. - -7. Edit. Text widgets support the standard Motif editing characters -plus many Emacs editing characters. Backspace and Control-h erase the -character to the left of the insertion cursor. Delete and Control-d -erase the character to the right of the insertion cursor. Meta-backspace -deletes the word to the left of the insertion cursor, and Meta-d deletes -the word to the right of the insertion cursor. Control-k deletes from -the insertion cursor to the end of the line, or it deletes the newline -character if that is the only thing left on the line. Control-o opens -a new line by inserting a newline character to the right of the insertion -cursor. Control-t transposes the two characters on either side of the -insertion cursor. Control-z undoes the last editing action performed, -and } - -switch [tk windowingsystem] { - "aqua" - "x11" { - $w.text insert end "Control-Shift-z" - } - "win32" { - $w.text insert end "Control-y" - } -} - -$w.text insert end { redoes undone edits. - -7. Resize the window. This widget has been configured with the "setGrid" -option on, so that if you resize the window it will always resize to an -even number of characters high and wide. Also, if you make the window -narrow you can see that long lines automatically wrap around onto -additional lines so that all the information is always visible.} -$w.text mark set insert 0.0 diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/textpeer.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/textpeer.tcl @@ -1,62 +0,0 @@ -# textpeer.tcl -- -# -# This demonstration script creates a pair of text widgets that can edit a -# single logical buffer. This is particularly useful when editing related text -# in two (or more) parts of the same file. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .textpeer -catch {destroy $w} -toplevel $w -wm title $w "Text Widget Peering Demonstration" -wm iconname $w "textpeer" -positionWindow $w - -set count 0 - -## Define a widget that we peer from; it won't ever actually be shown though -set first [text $w.text[incr count]] -$first insert end "This is a coupled pair of text widgets; they are peers to " -$first insert end "each other. They have the same underlying data model, but " -$first insert end "can show different locations, have different current edit " -$first insert end "locations, and have different selections. You can also " -$first insert end "create additional peers of any of these text widgets using " -$first insert end "the Make Peer button beside the text widget to clone, and " -$first insert end "delete a particular peer widget using the Delete Peer " -$first insert end "button." - -## Procedures to make and kill clones; most of this is just so that the demo -## looks nice... -proc makeClone {w parent} { - global count - set t [$parent peer create $w.text[incr count] -yscroll "$w.sb$count set"\ - -height 10 -wrap word] - set sb [ttk::scrollbar $w.sb$count -command "$t yview" -orient vertical] - set b1 [button $w.clone$count -command "makeClone $w $t" \ - -text "Make Peer"] - set b2 [button $w.kill$count -command "killClone $w $count" \ - -text "Delete Peer"] - set row [expr {$count * 2}] - grid $t $sb $b1 -sticky nsew -row $row - grid ^ ^ $b2 -row [incr row] - grid configure $b1 $b2 -sticky new - grid rowconfigure $w $b2 -weight 1 -} -proc killClone {w count} { - destroy $w.text$count $w.sb$count - destroy $w.clone$count $w.kill$count -} - -## Now set up the GUI -makeClone $w $first -makeClone $w $first -destroy $first - -## See Code / Dismiss buttons -grid [addSeeDismiss $w.buttons $w] - - -sticky ew -row 5000 -grid columnconfigure $w 0 -weight 1 diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/timer b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/timer @@ -1,47 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish8.6 "$0" ${1+"$@"} - -# timer -- -# This script generates a counter with start and stop buttons. - -package require Tk - -label .counter -text 0.00 -relief raised -width 10 -padx 2m -pady 1m -button .start -text Start -command { - if {$stopped} { - set stopped 0 - set startMoment [clock clicks -milliseconds] - tick - .stop configure -state normal - .start configure -state disabled - } -} -button .stop -text Stop -state disabled -command { - set stopped 1 - .stop configure -state disabled - .start configure -state normal -} -pack .counter -side bottom -fill both -pack .start -side left -fill both -expand yes -pack .stop -side right -fill both -expand yes - -set startMoment {} - -set stopped 1 - -proc tick {} { - global startMoment stopped - if {$stopped} {return} - after 50 tick - set elapsedMS [expr {[clock clicks -milliseconds] - $startMoment}] - .counter config -text [format "%.2f" [expr {double($elapsedMS)/1000}]] -} - -bind . <Control-c> {destroy .} -bind . <Control-q> {destroy .} -focus . - -# Local Variables: -# mode: tcl -# End: diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/toolbar.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/toolbar.tcl @@ -1,92 +0,0 @@ -# toolbar.tcl -- -# -# This demonstration script creates a toolbar that can be torn off. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .toolbar -destroy $w -toplevel $w -wm title $w "Toolbar Demonstration" -wm iconname $w "toolbar" -positionWindow $w - -ttk::label $w.msg -wraplength 4i -text "This is a demonstration of how to do\ - a toolbar that is styled correctly and which can be torn off. The\ - buttons are configured to be \u201Ctoolbar style\u201D buttons by\ - telling them that they are to use the Toolbutton style. At the left\ - end of the toolbar is a simple marker that the cursor changes to a\ - movement icon over; drag that away from the toolbar to tear off the\ - whole toolbar into a separate toplevel widget. When the dragged-off\ - toolbar is no longer needed, just close it like any normal toplevel\ - and it will reattach to the window it was torn off from." - -## Set up the toolbar hull -set t [frame $w.toolbar] ;# Must be a frame! -ttk::separator $w.sep -ttk::frame $t.tearoff -cursor fleur -ttk::separator $t.tearoff.to -orient vertical -ttk::separator $t.tearoff.to2 -orient vertical -pack $t.tearoff.to -fill y -expand 1 -padx 2 -side left -pack $t.tearoff.to2 -fill y -expand 1 -side left -ttk::frame $t.contents -grid $t.tearoff $t.contents -sticky nsew -grid columnconfigure $t $t.contents -weight 1 -grid columnconfigure $t.contents 1000 -weight 1 - -## Bindings so that the toolbar can be torn off and reattached -bind $t.tearoff <B1-Motion> [list tearoff $t %X %Y] -bind $t.tearoff.to <B1-Motion> [list tearoff $t %X %Y] -bind $t.tearoff.to2 <B1-Motion> [list tearoff $t %X %Y] -proc tearoff {w x y} { - if {[string match $w* [winfo containing $x $y]]} { - return - } - grid remove $w - grid remove $w.tearoff - wm manage $w - wm protocol $w WM_DELETE_WINDOW [list untearoff $w] -} -proc untearoff {w} { - wm forget $w - grid $w.tearoff - grid $w -} - -## Toolbar contents -ttk::button $t.button -text "Button" -style Toolbutton -command [list \ - $w.txt insert end "Button Pressed\n"] -ttk::checkbutton $t.check -text "Check" -variable check -style Toolbutton \ - -command [concat [list $w.txt insert end] {"check is $check\n"}] -ttk::menubutton $t.menu -text "Menu" -menu $t.menu.m -ttk::combobox $t.combo -value [lsort [font families]] -state readonly -menu $t.menu.m -$t.menu.m add command -label "Just" -command [list $w.txt insert end Just\n] -$t.menu.m add command -label "An" -command [list $w.txt insert end An\n] -$t.menu.m add command -label "Example" \ - -command [list $w.txt insert end Example\n] -bind $t.combo <<ComboboxSelected>> [list changeFont $w.txt $t.combo] -proc changeFont {txt combo} { - $txt configure -font [list [$combo get] 10] -} - -## Some content for the rest of the toplevel -text $w.txt -width 40 -height 10 -interp alias {} doInsert {} $w.txt insert end ;# Make bindings easy to write - -## Arrange contents -grid $t.button $t.check $t.menu $t.combo -in $t.contents -padx 2 -sticky ns -grid $t -sticky ew -grid $w.sep -sticky ew -grid $w.msg -sticky ew -grid $w.txt -sticky nsew -grid rowconfigure $w $w.txt -weight 1 -grid columnconfigure $w $w.txt -weight 1 - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -grid $btns -sticky ew diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/tree.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/tree.tcl @@ -1,88 +0,0 @@ -# tree.tcl -- -# -# This demonstration script creates a toplevel window containing a Ttk -# tree widget. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .tree -catch {destroy $w} -toplevel $w -wm title $w "Directory Browser" -wm iconname $w "tree" -positionWindow $w - -## Explanatory text -ttk::label $w.msg -font $font -wraplength 4i -justify left -anchor n -padding {10 2 10 6} -text "Ttk is the new Tk themed widget set. One of the widgets it includes is a tree widget, which allows the user to browse a hierarchical data-set such as a filesystem. The tree widget not only allows for the tree part itself, but it also supports an arbitrary number of additional columns which can show additional data (in this case, the size of the files found in your filesystem). You can also change the width of the columns by dragging the boundary between them." -pack $w.msg -fill x - -## See Code / Dismiss -pack [addSeeDismiss $w.seeDismiss $w] -side bottom -fill x - -## Code to populate the roots of the tree (can be more than one on Windows) -proc populateRoots {tree} { - foreach dir [lsort -dictionary [file volumes]] { - populateTree $tree [$tree insert {} end -text $dir \ - -values [list $dir directory]] - } -} - -## Code to populate a node of the tree -proc populateTree {tree node} { - if {[$tree set $node type] ne "directory"} { - return - } - set path [$tree set $node fullpath] - $tree delete [$tree children $node] - foreach f [lsort -dictionary [glob -nocomplain -dir $path *]] { - set type [file type $f] - set id [$tree insert $node end -text [file tail $f] \ - -values [list $f $type]] - - if {$type eq "directory"} { - ## Make it so that this node is openable - $tree insert $id 0 -text dummy ;# a dummy - $tree item $id -text [file tail $f]/ - - } elseif {$type eq "file"} { - set size [file size $f] - ## Format the file size nicely - if {$size >= 1024*1024*1024} { - set size [format %.1f\ GB [expr {$size/1024/1024/1024.}]] - } elseif {$size >= 1024*1024} { - set size [format %.1f\ MB [expr {$size/1024/1024.}]] - } elseif {$size >= 1024} { - set size [format %.1f\ kB [expr {$size/1024.}]] - } else { - append size " bytes" - } - $tree set $id size $size - } - } - - # Stop this code from rerunning on the current node - $tree set $node type processedDirectory -} - -## Create the tree and set it up -ttk::treeview $w.tree -columns {fullpath type size} -displaycolumns {size} \ - -yscroll "$w.vsb set" -xscroll "$w.hsb set" -ttk::scrollbar $w.vsb -orient vertical -command "$w.tree yview" -ttk::scrollbar $w.hsb -orient horizontal -command "$w.tree xview" -$w.tree heading \#0 -text "Directory Structure" -$w.tree heading size -text "File Size" -$w.tree column size -stretch 0 -width 70 -populateRoots $w.tree -bind $w.tree <<TreeviewOpen>> {populateTree %W [%W focus]} - -## Arrange the tree and its scrollbars in the toplevel -lower [ttk::frame $w.dummy] -pack $w.dummy -fill both -expand 1 -grid $w.tree $w.vsb -sticky nsew -in $w.dummy -grid $w.hsb -sticky nsew -in $w.dummy -grid columnconfigure $w.dummy 0 -weight 1 -grid rowconfigure $w.dummy 0 -weight 1 diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/ttkbut.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/ttkbut.tcl @@ -1,84 +0,0 @@ -# ttkbut.tcl -- -# -# This demonstration script creates a toplevel window containing several -# simple Ttk widgets, such as labels, labelframes, buttons, checkbuttons and -# radiobuttons. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .ttkbut -catch {destroy $w} -toplevel $w -wm title $w "Simple Ttk Widgets" -wm iconname $w "ttkbut" -positionWindow $w - -ttk::label $w.msg -font $font -wraplength 4i -justify left -text "Ttk is the new Tk themed widget set. This is a Ttk themed label, and below are three groups of Ttk widgets in Ttk labelframes. The first group are all buttons that set the current application theme when pressed. The second group contains three sets of checkbuttons, with a separator widget between the sets. Note that the \u201cEnabled\u201d button controls whether all the other themed widgets in this toplevel are in the disabled state. The third group has a collection of linked radiobuttons." -pack $w.msg -side top -fill x - -## See Code / Dismiss -pack [addSeeDismiss $w.seeDismiss $w {enabled cheese tomato basil oregano happyness}]\ - -side bottom -fill x - -## Add buttons for setting the theme -ttk::labelframe $w.buttons -text "Buttons" -foreach theme [ttk::themes] { - ttk::button $w.buttons.$theme -text $theme \ - -command [list ttk::setTheme $theme] - pack $w.buttons.$theme -pady 2 -} - -## Helper procedure for the top checkbutton -proc setState {rootWidget exceptThese value} { - if {$rootWidget in $exceptThese} { - return - } - ## Non-Ttk widgets (e.g. the toplevel) will fail, so make it silent - catch { - $rootWidget state $value - } - ## Recursively invoke on all children of this root that are in the same - ## toplevel widget - foreach w [winfo children $rootWidget] { - if {[winfo toplevel $w] eq [winfo toplevel $rootWidget]} { - setState $w $exceptThese $value - } - } -} - -## Set up the checkbutton group -ttk::labelframe $w.checks -text "Checkbuttons" -ttk::checkbutton $w.checks.e -text Enabled -variable enabled -command { - setState .ttkbut .ttkbut.checks.e \ - [expr {$enabled ? "!disabled" : "disabled"}] -} -set enabled 1 -## See ttk_widget(n) for other possible state flags -ttk::separator $w.checks.sep1 -ttk::checkbutton $w.checks.c1 -text Cheese -variable cheese -ttk::checkbutton $w.checks.c2 -text Tomato -variable tomato -ttk::separator $w.checks.sep2 -ttk::checkbutton $w.checks.c3 -text Basil -variable basil -ttk::checkbutton $w.checks.c4 -text Oregano -variable oregano -pack $w.checks.e $w.checks.sep1 $w.checks.c1 $w.checks.c2 $w.checks.sep2 \ - $w.checks.c3 $w.checks.c4 -fill x -pady 2 - -## Set up the radiobutton group -ttk::labelframe $w.radios -text "Radiobuttons" -ttk::radiobutton $w.radios.r1 -text "Great" -variable happyness -value great -ttk::radiobutton $w.radios.r2 -text "Good" -variable happyness -value good -ttk::radiobutton $w.radios.r3 -text "OK" -variable happyness -value ok -ttk::radiobutton $w.radios.r4 -text "Poor" -variable happyness -value poor -ttk::radiobutton $w.radios.r5 -text "Awful" -variable happyness -value awful -pack $w.radios.r1 $w.radios.r2 $w.radios.r3 $w.radios.r4 $w.radios.r5 \ - -fill x -padx 3 -pady 2 - -## Arrange things neatly -pack [ttk::frame $w.f] -fill both -expand 1 -lower $w.f -grid $w.buttons $w.checks $w.radios -in $w.f -sticky nwe -pady 2 -padx 3 -grid columnconfigure $w.f {0 1 2} -weight 1 -uniform yes diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/ttkmenu.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/ttkmenu.tcl @@ -1,53 +0,0 @@ -# ttkmenu.tcl -- -# -# This demonstration script creates a toplevel window containing several Ttk -# menubutton widgets. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .ttkmenu -catch {destroy $w} -toplevel $w -wm title $w "Ttk Menu Buttons" -wm iconname $w "ttkmenu" -positionWindow $w - -ttk::label $w.msg -font $font -wraplength 4i -justify left -text "Ttk is the new Tk themed widget set, and one widget that is available in themed form is the menubutton. Below are some themed menu buttons that allow you to pick the current theme in use. Notice how picking a theme changes the way that the menu buttons themselves look, and that the central menu button is styled differently (in a way that is normally suitable for toolbars). However, there are no themed menus; the standard Tk menus were judged to have a sufficiently good look-and-feel on all platforms, especially as they are implemented as native controls in many places." -pack $w.msg [ttk::separator $w.msgSep] -side top -fill x - -## See Code / Dismiss -pack [addSeeDismiss $w.seeDismiss $w] -side bottom -fill x - -ttk::menubutton $w.m1 -menu $w.m1.menu -text "Select a theme" -direction above -ttk::menubutton $w.m2 -menu $w.m1.menu -text "Select a theme" -direction left -ttk::menubutton $w.m3 -menu $w.m1.menu -text "Select a theme" -direction right -ttk::menubutton $w.m4 -menu $w.m1.menu -text "Select a theme" \ - -direction flush -style TMenubutton.Toolbutton -ttk::menubutton $w.m5 -menu $w.m1.menu -text "Select a theme" -direction below - -menu $w.m1.menu -tearoff 0 -menu $w.m2.menu -tearoff 0 -menu $w.m3.menu -tearoff 0 -menu $w.m4.menu -tearoff 0 -menu $w.m5.menu -tearoff 0 - -foreach theme [ttk::themes] { - $w.m1.menu add command -label $theme -command [list ttk::setTheme $theme] - $w.m2.menu add command -label $theme -command [list ttk::setTheme $theme] - $w.m3.menu add command -label $theme -command [list ttk::setTheme $theme] - $w.m4.menu add command -label $theme -command [list ttk::setTheme $theme] - $w.m5.menu add command -label $theme -command [list ttk::setTheme $theme] -} - -pack [ttk::frame $w.f] -fill x -pack [ttk::frame $w.f1] -fill both -expand yes -lower $w.f - -grid anchor $w.f center -grid x $w.m1 x -in $w.f -padx 3 -pady 2 -grid $w.m2 $w.m4 $w.m3 -in $w.f -padx 3 -pady 2 -grid x $w.m5 x -in $w.f -padx 3 -pady 2 diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/ttknote.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/ttknote.tcl @@ -1,57 +0,0 @@ -# ttknote.tcl -- -# -# This demonstration script creates a toplevel window containing a Ttk -# notebook widget. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .ttknote -catch {destroy $w} -toplevel $w -wm title $w "Ttk Notebook Widget" -wm iconname $w "ttknote" -positionWindow $w - -## See Code / Dismiss -pack [addSeeDismiss $w.seeDismiss $w] -side bottom -fill x - -ttk::frame $w.f -pack $w.f -fill both -expand 1 -set w $w.f - -## Make the notebook and set up Ctrl+Tab traversal -ttk::notebook $w.note -pack $w.note -fill both -expand 1 -padx 2 -pady 3 -ttk::notebook::enableTraversal $w.note - -## Popuplate the first pane -ttk::frame $w.note.msg -ttk::label $w.note.msg.m -font $font -wraplength 4i -justify left -anchor n -text "Ttk is the new Tk themed widget set. One of the widgets it includes is the notebook widget, which provides a set of tabs that allow the selection of a group of panels, each with distinct content. They are a feature of many modern user interfaces. Not only can the tabs be selected with the mouse, but they can also be switched between using Ctrl+Tab when the notebook page heading itself is selected. Note that the second tab is disabled, and cannot be selected." -ttk::button $w.note.msg.b -text "Neat!" -underline 0 -command { - set neat "Yeah, I know..." - after 500 {set neat {}} -} -bind $w <Alt-n> "focus $w.note.msg.b; $w.note.msg.b invoke" -ttk::label $w.note.msg.l -textvariable neat -$w.note add $w.note.msg -text "Description" -underline 0 -padding 2 -grid $w.note.msg.m - -sticky new -pady 2 -grid $w.note.msg.b $w.note.msg.l -pady {2 4} -grid rowconfigure $w.note.msg 1 -weight 1 -grid columnconfigure $w.note.msg {0 1} -weight 1 -uniform 1 - -## Populate the second pane. Note that the content doesn't really matter -ttk::frame $w.note.disabled -$w.note add $w.note.disabled -text "Disabled" -state disabled - -## Popuplate the third pane -ttk::frame $w.note.editor -$w.note add $w.note.editor -text "Text Editor" -underline 0 -text $w.note.editor.t -width 40 -height 10 -wrap char \ - -yscroll "$w.note.editor.s set" -ttk::scrollbar $w.note.editor.s -orient vertical -command "$w.note.editor.t yview" -pack $w.note.editor.s -side right -fill y -padx {0 2} -pady 2 -pack $w.note.editor.t -fill both -expand 1 -pady 2 -padx {2 0} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/ttkpane.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/ttkpane.tcl @@ -1,112 +0,0 @@ -# ttkpane.tcl -- -# -# This demonstration script creates a Ttk pane with some content. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .ttkpane -catch {destroy $w} -toplevel $w -wm title $w "Themed Nested Panes" -wm iconname $w "ttkpane" -positionWindow $w - -ttk::label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration shows off a nested set of themed paned windows. Their sizes can be changed by grabbing the area between each contained pane and dragging the divider." -pack $w.msg [ttk::separator $w.msgSep] -side top -fill x - -## See Code / Dismiss -pack [addSeeDismiss $w.seeDismiss $w] -side bottom -fill x - -ttk::frame $w.f -pack $w.f -fill both -expand 1 -set w $w.f -ttk::panedwindow $w.outer -orient horizontal -$w.outer add [ttk::panedwindow $w.outer.inLeft -orient vertical] -$w.outer add [ttk::panedwindow $w.outer.inRight -orient vertical] -$w.outer.inLeft add [ttk::labelframe $w.outer.inLeft.top -text Button] -$w.outer.inLeft add [ttk::labelframe $w.outer.inLeft.bot -text Clocks] -$w.outer.inRight add [ttk::labelframe $w.outer.inRight.top -text Progress] -$w.outer.inRight add [ttk::labelframe $w.outer.inRight.bot -text Text] -if {[tk windowingsystem] eq "aqua"} { - foreach i [list inLeft.top inLeft.bot inRight.top inRight.bot] { - $w.outer.$i configure -padding 3 - } -} - -# Fill the button pane -ttk::button $w.outer.inLeft.top.b -text "Press Me" -command { - tk_messageBox -type ok -icon info -message "Ouch!" -detail "That hurt..." \ - -parent .ttkpane -title "Button Pressed" -} -pack $w.outer.inLeft.top.b -padx 2 -pady 5 - -# Fill the clocks pane -set i 0 -proc every {delay script} { - uplevel #0 $script - after $delay [list every $delay $script] -} -set testzones { - :Europe/Berlin - :America/Argentina/Buenos_Aires - :Africa/Johannesburg - :Europe/London - :America/Los_Angeles - :Europe/Moscow - :America/New_York - :Asia/Singapore - :Australia/Sydney - :Asia/Tokyo -} -# Force a pre-load of all the timezones needed; otherwise can end up -# poor-looking synch problems! -set zones {} -foreach zone $testzones { - if {![catch {clock format 0 -timezone $zone}]} { - lappend zones $zone - } -} -if {[llength $zones] < 2} { lappend zones -0200 :GMT :UTC +0200 } -foreach zone $zones { - set city [string map {_ " "} [regexp -inline {[^/]+$} $zone]] - if {$i} { - pack [ttk::separator $w.outer.inLeft.bot.s$i] -fill x - } - ttk::label $w.outer.inLeft.bot.l$i -text $city -anchor w - ttk::label $w.outer.inLeft.bot.t$i -textvariable time($zone) -anchor w - pack $w.outer.inLeft.bot.l$i $w.outer.inLeft.bot.t$i -fill x - every 1000 "set time($zone) \[clock format \[clock seconds\] -timezone $zone -format %T\]" - incr i -} - -# Fill the progress pane -ttk::progressbar $w.outer.inRight.top.progress -mode indeterminate -pack $w.outer.inRight.top.progress -fill both -expand 1 -$w.outer.inRight.top.progress start - -# Fill the text pane -if {[tk windowingsystem] ne "aqua"} { - # The trick with the ttk::frame makes the text widget look like it fits with - # the current Ttk theme despite not being a themed widget itself. It is done - # by styling the frame like an entry, turning off the border in the text - # widget, and putting the text widget in the frame with enough space to allow - # the surrounding border to show through (2 pixels seems to be enough). - ttk::frame $w.outer.inRight.bot.f -style TEntry - text $w.txt -wrap word -yscroll "$w.sb set" -width 30 -borderwidth 0 - pack $w.txt -fill both -expand 1 -in $w.outer.inRight.bot.f -pady 2 -padx 2 - ttk::scrollbar $w.sb -orient vertical -command "$w.txt yview" - pack $w.sb -side right -fill y -in $w.outer.inRight.bot - pack $w.outer.inRight.bot.f -fill both -expand 1 - pack $w.outer -fill both -expand 1 -} else { - text $w.txt -wrap word -yscroll "$w.sb set" -width 30 -borderwidth 0 - scrollbar $w.sb -orient vertical -command "$w.txt yview" - pack $w.sb -side right -fill y -in $w.outer.inRight.bot - pack $w.txt -fill both -expand 1 -in $w.outer.inRight.bot - pack $w.outer -fill both -expand 1 -padx 10 -pady {6 10} -} - diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/ttkprogress.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/ttkprogress.tcl @@ -1,46 +0,0 @@ -# ttkprogress.tcl -- -# -# This demonstration script creates several progress bar widgets. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .ttkprogress -catch {destroy $w} -toplevel $w -wm title $w "Progress Bar Demonstration" -wm iconname $w "ttkprogress" -positionWindow $w - -ttk::label $w.msg -font $font -wraplength 4i -justify left -text "Below are two progress bars. The top one is a \u201Cdeterminate\u201D progress bar, which is used for showing how far through a defined task the program has got. The bottom one is an \u201Cindeterminate\u201D progress bar, which is used to show that the program is busy but does not know how long for. Both are run here in self-animated mode, which can be turned on and off using the buttons underneath." -pack $w.msg -side top -fill x - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -ttk::frame $w.f -pack $w.f -fill both -expand 1 -set w $w.f - -proc doBars {op args} { - foreach w $args { - $w $op - } -} -ttk::progressbar $w.p1 -mode determinate -ttk::progressbar $w.p2 -mode indeterminate -ttk::button $w.start -text "Start Progress" -command [list \ - doBars start $w.p1 $w.p2] -ttk::button $w.stop -text "Stop Progress" -command [list \ - doBars stop $w.p1 $w.p2] - -grid $w.p1 - -pady 5 -padx 10 -grid $w.p2 - -pady 5 -padx 10 -grid $w.start $w.stop -padx 10 -pady 5 -grid configure $w.start -sticky e -grid configure $w.stop -sticky w -grid columnconfigure $w all -weight 1 diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/ttkscale.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/ttkscale.tcl @@ -1,39 +0,0 @@ -# ttkscale.tcl -- -# -# This demonstration script shows an example with a horizontal scale. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .ttkscale -catch {destroy $w} -toplevel $w -bg [ttk::style lookup TLabel -background] -wm title $w "Themed Scale Demonstration" -wm iconname $w "ttkscale" -positionWindow $w - -pack [ttk::frame [set w $w.contents]] -fill both -expand 1 - -ttk::label $w.msg -font $font -wraplength 3.5i -justify left -text "A label tied to a horizontal scale is displayed below. If you click or drag mouse button 1 in the scale, you can change the contents of the label; a callback command is used to couple the slider to both the text and the coloring of the label." -pack $w.msg -side top -padx .5c - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons [winfo toplevel $w]] -pack $btns -side bottom -fill x - -ttk::frame $w.frame -borderwidth 10 -pack $w.frame -side top -fill x - -# List of colors from rainbox; "Indigo" is not a standard color -set colorList {Red Orange Yellow Green Blue Violet} -ttk::label $w.frame.label -ttk::scale $w.frame.scale -from 0 -to 5 -command [list apply {{w idx} { - set c [lindex $::colorList [tcl::mathfunc::int $idx]] - $w.frame.label configure -foreground $c -text "Color: $c" -}} $w] -# Trigger the setting of the label's text -$w.frame.scale set 0 -pack $w.frame.label $w.frame.scale diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/twind.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/twind.tcl @@ -1,327 +0,0 @@ -# twind.tcl -- -# -# This demonstration script creates a text widget with a bunch of -# embedded windows. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .twind -catch {destroy $w} -toplevel $w -wm title $w "Text Demonstration - Embedded Windows and Other Features" -wm iconname $w "Embedded Windows" -positionWindow $w - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -frame $w.f -highlightthickness 1 -borderwidth 1 -relief sunken -set t $w.f.text -text $t -yscrollcommand "$w.scroll set" -setgrid true -font $font -width 70 \ - -height 35 -wrap word -highlightthickness 0 -borderwidth 0 -pack $t -expand yes -fill both -ttk::scrollbar $w.scroll -command "$t yview" -pack $w.scroll -side right -fill y -panedwindow $w.pane -pack $w.pane -expand yes -fill both -$w.pane add $w.f -# Import to raise given creation order above -raise $w.f - -$t tag configure center -justify center -spacing1 5m -spacing3 5m -$t tag configure buttons -lmargin1 1c -lmargin2 1c -rmargin 1c \ - -spacing1 3m -spacing2 0 -spacing3 0 - -button $t.on -text "Turn On" -command "textWindOn $w" \ - -cursor top_left_arrow -button $t.off -text "Turn Off" -command "textWindOff $w" \ - -cursor top_left_arrow - -$t insert end "A text widget can contain many different kinds of items, " -$t insert end "both active and passive. It can lay these out in various " -$t insert end "ways, with wrapping, tabs, centering, etc. In addition, " -$t insert end "when the contents are too big for the window, smooth " -$t insert end "scrolling in all directions is provided.\n\n" - -$t insert end "A text widget can contain other widgets embedded " -$t insert end "it. These are called \"embedded windows\", " -$t insert end "and they can consist of arbitrary widgets. " -$t insert end "For example, here are two embedded button " -$t insert end "widgets. You can click on the first button to " -$t window create end -window $t.on -$t insert end " horizontal scrolling, which also turns off " -$t insert end "word wrapping. Or, you can click on the second " -$t insert end "button to\n" -$t window create end -window $t.off -$t insert end " horizontal scrolling and turn back on word wrapping.\n\n" - -$t insert end "Or, here is another example. If you " -$t window create end -create { - button %W.click -text "Click Here" -command "textWindPlot %W" \ - -cursor top_left_arrow} - -$t insert end " a canvas displaying an x-y plot will appear right here." -$t mark set plot insert -$t mark gravity plot left -$t insert end " You can drag the data points around with the mouse, " -$t insert end "or you can click here to " -$t window create end -create { - button %W.delete -text "Delete" -command "textWindDel %W" \ - -cursor top_left_arrow -} -$t insert end " the plot again.\n\n" - -$t insert end "You can also create multiple text widgets each of which " -$t insert end "display the same underlying text. Click this button to " -$t window create end \ - -create {button %W.peer -text "Make A Peer" -command "textMakePeer %W" \ - -cursor top_left_arrow} -padx 3 -$t insert end " widget. Notice how peer widgets can have different " -$t insert end "font settings, and by default contain all the images " -$t insert end "of the 'parent', but that the embedded windows, " -$t insert end "such as buttons may not appear in the peer. To ensure " -$t insert end "that embedded windows appear in all peers you can set the " -$t insert end "'-create' option to a script or a string containing %W. " -$t insert end "(The plot above and the 'Make A Peer' button are " -$t insert end "designed to show up in all peers.) A good use of " -$t insert end "peers is for " -$t window create end \ - -create {button %W.split -text "Split Windows" -command "textSplitWindow %W" \ - -cursor top_left_arrow} -padx 3 -$t insert end " \n\n" - -$t insert end "Users of previous versions of Tk will also be interested " -$t insert end "to note that now cursor movement is now by visual line by " -$t insert end "default, and that all scrolling of this widget is by pixel.\n\n" - -$t insert end "You may also find it useful to put embedded windows in " -$t insert end "a text without any actual text. In this case the " -$t insert end "text widget acts like a geometry manager. For " -$t insert end "example, here is a collection of buttons laid out " -$t insert end "neatly into rows by the text widget. These buttons " -$t insert end "can be used to change the background color of the " -$t insert end "text widget (\"Default\" restores the color to " -$t insert end "its default). If you click on the button labeled " -$t insert end "\"Short\", it changes to a longer string so that " -$t insert end "you can see how the text widget automatically " -$t insert end "changes the layout. Click on the button again " -$t insert end "to restore the short string.\n" - -$t insert end "\nNOTE: these buttons will not appear in peers!\n" "peer_warning" -button $t.default -text Default -command "embDefBg $t" \ - -cursor top_left_arrow -$t window create end -window $t.default -padx 3 -global embToggle -set embToggle Short -checkbutton $t.toggle -textvariable embToggle -indicatoron 0 \ - -variable embToggle -onvalue "A much longer string" \ - -offvalue "Short" -cursor top_left_arrow -pady 5 -padx 2 -$t window create end -window $t.toggle -padx 3 -pady 2 -set i 1 -foreach color {AntiqueWhite3 Bisque1 Bisque2 Bisque3 Bisque4 - SlateBlue3 RoyalBlue1 SteelBlue2 DeepSkyBlue3 LightBlue1 - DarkSlateGray1 Aquamarine2 DarkSeaGreen2 SeaGreen1 - Yellow1 IndianRed1 IndianRed2 Tan1 Tan4} { - button $t.color$i -text $color -cursor top_left_arrow -command \ - "$t configure -bg $color" - $t window create end -window $t.color$i -padx 3 -pady 2 - incr i -} -$t tag add buttons $t.default end - -button $t.bigB -text "Big borders" -command "textWindBigB $t" \ - -cursor top_left_arrow -button $t.smallB -text "Small borders" -command "textWindSmallB $t" \ - -cursor top_left_arrow -button $t.bigH -text "Big highlight" -command "textWindBigH $t" \ - -cursor top_left_arrow -button $t.smallH -text "Small highlight" -command "textWindSmallH $t" \ - -cursor top_left_arrow -button $t.bigP -text "Big pad" -command "textWindBigP $t" \ - -cursor top_left_arrow -button $t.smallP -text "Small pad" -command "textWindSmallP $t" \ - -cursor top_left_arrow - -set text_normal(border) [$t cget -borderwidth] -set text_normal(highlight) [$t cget -highlightthickness] -set text_normal(pad) [$t cget -padx] - -$t insert end "\nYou can also change the usual border width and " -$t insert end "highlightthickness and padding.\n" -$t window create end -window $t.bigB -$t window create end -window $t.smallB -$t window create end -window $t.bigH -$t window create end -window $t.smallH -$t window create end -window $t.bigP -$t window create end -window $t.smallP - -$t insert end "\n\nFinally, images fit comfortably in text widgets too:" - -$t image create end -image \ - [image create photo -file [file join $tk_demoDirectory images ouster.png]] - -proc textWindBigB w { - $w configure -borderwidth 15 -} - -proc textWindBigH w { - $w configure -highlightthickness 15 -} - -proc textWindBigP w { - $w configure -padx 15 -pady 15 -} - -proc textWindSmallB w { - $w configure -borderwidth $::text_normal(border) -} - -proc textWindSmallH w { - $w configure -highlightthickness $::text_normal(highlight) -} - -proc textWindSmallP w { - $w configure -padx $::text_normal(pad) -pady $::text_normal(pad) -} - - -proc textWindOn w { - catch {destroy $w.scroll2} - set t $w.f.text - ttk::scrollbar $w.scroll2 -orient horizontal -command "$t xview" - pack $w.scroll2 -after $w.buttons -side bottom -fill x - $t configure -xscrollcommand "$w.scroll2 set" -wrap none -} - -proc textWindOff w { - catch {destroy $w.scroll2} - set t $w.f.text - $t configure -xscrollcommand {} -wrap word -} - -proc textWindPlot t { - set c $t.c - if {[winfo exists $c]} { - return - } - - while {[string first [$t get plot] " \t\n"] >= 0} { - $t delete plot - } - $t insert plot "\n" - - $t window create plot -create {createPlot %W} - $t tag add center plot - $t insert plot "\n" -} - -proc createPlot {t} { - set c $t.c - - canvas $c -relief sunken -width 450 -height 300 -cursor top_left_arrow - - set font {Helvetica 18} - - $c create line 100 250 400 250 -width 2 - $c create line 100 250 100 50 -width 2 - $c create text 225 20 -text "A Simple Plot" -font $font -fill brown - - for {set i 0} {$i <= 10} {incr i} { - set x [expr {100 + ($i*30)}] - $c create line $x 250 $x 245 -width 2 - $c create text $x 254 -text [expr {10*$i}] -anchor n -font $font - } - for {set i 0} {$i <= 5} {incr i} { - set y [expr {250 - ($i*40)}] - $c create line 100 $y 105 $y -width 2 - $c create text 96 $y -text [expr {$i*50}].0 -anchor e -font $font - } - - foreach point { - {12 56} {20 94} {33 98} {32 120} {61 180} {75 160} {98 223} - } { - set x [expr {100 + (3*[lindex $point 0])}] - set y [expr {250 - (4*[lindex $point 1])/5}] - set item [$c create oval [expr {$x-6}] [expr {$y-6}] \ - [expr {$x+6}] [expr {$y+6}] -width 1 -outline black \ - -fill SkyBlue2] - $c addtag point withtag $item - } - - $c bind point <Any-Enter> "$c itemconfig current -fill red" - $c bind point <Any-Leave> "$c itemconfig current -fill SkyBlue2" - $c bind point <1> "embPlotDown $c %x %y" - $c bind point <ButtonRelease-1> "$c dtag selected" - bind $c <B1-Motion> "embPlotMove $c %x %y" - return $c -} - -set embPlot(lastX) 0 -set embPlot(lastY) 0 - -proc embPlotDown {w x y} { - global embPlot - $w dtag selected - $w addtag selected withtag current - $w raise current - set embPlot(lastX) $x - set embPlot(lastY) $y -} - -proc embPlotMove {w x y} { - global embPlot - $w move selected [expr {$x-$embPlot(lastX)}] [expr {$y-$embPlot(lastY)}] - set embPlot(lastX) $x - set embPlot(lastY) $y -} - -proc textWindDel t { - if {[winfo exists $t.c]} { - $t delete $t.c - while {[string first [$t get plot] " \t\n"] >= 0} { - $t delete plot - } - $t insert plot " " - } -} - -proc embDefBg t { - $t configure -background [lindex [$t configure -background] 3] -} - -proc textMakePeer {parent} { - set n 1 - while {[winfo exists .peer$n]} { incr n } - set w [toplevel .peer$n] - wm title $w "Text Peer #$n" - frame $w.f -highlightthickness 1 -borderwidth 1 -relief sunken - set t [$parent peer create $w.f.text -yscrollcommand "$w.scroll set" \ - -borderwidth 0 -highlightthickness 0] - $t tag configure peer_warning -font boldFont - pack $t -expand yes -fill both - ttk::scrollbar $w.scroll -command "$t yview" - pack $w.scroll -side right -fill y - pack $w.f -expand yes -fill both -} - -proc textSplitWindow {textW} { - if {$textW eq ".twind.f.text"} { - if {[winfo exists .twind.peer]} { - destroy .twind.peer - } else { - set parent [winfo parent $textW] - set w [winfo parent $parent] - set t [$textW peer create $w.peer \ - -yscrollcommand "$w.scroll set"] - $t tag configure peer_warning -font boldFont - $w.pane add $t - } - } else { - return - } -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/unicodeout.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/unicodeout.tcl @@ -1,137 +0,0 @@ -# unicodeout.tcl -- -# -# This demonstration script shows how you can produce output (in label -# widgets) using many different alphabets. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .unicodeout -catch {destroy $w} -toplevel $w -wm title $w "Unicode Label Demonstration" -wm iconname $w "unicodeout" -positionWindow $w - -label $w.msg -font $font -wraplength 4i -anchor w -justify left \ - -text "This is a sample of Tk's support for languages that use\ - non-Western character sets. However, what you will actually see\ - below depends largely on what character sets you have installed,\ - and what you see for characters that are not present varies greatly\ - between platforms as well. The strings are written in Tcl using\ - UNICODE characters using the \\uXXXX escape so as to do so in a\ - portable fashion." -pack $w.msg -side top - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -## The frame that will contain the sample texts. -pack [frame $w.f] -side bottom -expand 1 -fill both -padx 2m -pady 1m -grid columnconfigure $w.f 1 -weight 1 -set i 0 -proc addSample {w language args} { - global font i - set sample [join $args ""] - set j [incr i] - label $w.f.l$j -font $font -text "${language}:" -anchor nw -pady 0 - label $w.f.s$j -font $font -text $sample -anchor nw -width 30 -pady 0 - grid $w.f.l$j $w.f.s$j -sticky ew -pady 0 - grid configure $w.f.l$j -padx 1m -} - -## A helper procedure that determines what form to use to express languages -## that have complex rendering rules... -proc usePresentationFormsFor {language} { - switch [tk windowingsystem] { - aqua { - # OSX wants natural character order; the renderer knows how to - # compose things for display for all languages. - return false - } - x11 { - # The X11 font renderers that Tk supports all know nothing about - # composing characters, so we need to use presentation forms. - return true - } - win32 { - # On Windows, we need to determine whether the font system will - # render right-to-left text. This varies by language! - try { - package require registry - set rkey [join { - HKEY_LOCAL_MACHINE - SOFTWARE - Microsoft - {Windows NT} - CurrentVersion - LanguagePack - } \\] - return [expr { - [string toupper $language] ni [registry values $rkey] - }] - } trap error {} { - # Cannot work it out, so use presentation forms. - return true - } - } - default { - # Default to using presentation forms. - return true - } - } -} - -## Processing when some characters are not currently cached by the display -## engine might take a while, so make sure we're displaying something in the -## meantime... -pack [label $w.wait -text "Please wait while loading fonts..." \ - -font {Helvetica 12 italic}] -set oldCursor [$w cget -cursor] -$w conf -cursor watch -update - -## Add the samples... -if {[usePresentationFormsFor Arabic]} { - # Using presentation forms (pre-layouted) - addSample $w Arabic \ - "\uFE94\uFEF4\uFE91\uFEAE\uFECC\uFEDF\uFE8D " \ - "\uFE94\uFEE4\uFEE0\uFEDC\uFEDF\uFE8D" -} else { - # Using standard text characters - addSample $w Arabic \ - "\u0627\u0644\u0643\u0644\u0645\u0629 " \ - "\u0627\u0644\u0639\u0631\u0628\u064A\u0629" -} -addSample $w "Trad. Chinese" "\u4E2D\u570B\u7684\u6F22\u5B57" -addSample $w "Simpl. Chinese" "\u6C49\u8BED" -addSample $w French "Langue fran\u00E7aise" -addSample $w Greek \ - "\u0395\u03BB\u03BB\u03B7\u03BD\u03B9\u03BA\u03AE " \ - "\u03B3\u03BB\u03CE\u03C3\u03C3\u03B1" -if {[usePresentationFormsFor Hebrew]} { - # Visual order (pre-layouted) - addSample $w Hebrew \ - "\u05EA\u05D9\u05E8\u05D1\u05E2 \u05D1\u05EA\u05DB" -} else { - # Standard logical order - addSample $w Hebrew \ - "\u05DB\u05EA\u05D1 \u05E2\u05D1\u05E8\u05D9\u05EA" -} -addSample $w Hindi \ - "\u0939\u093f\u0928\u094d\u0926\u0940 \u092d\u093e\u0937\u093e" -addSample $w Icelandic "\u00CDslenska" -addSample $w Japanese \ - "\u65E5\u672C\u8A9E\u306E\u3072\u3089\u304C\u306A, " \ - "\u6F22\u5B57\u3068\u30AB\u30BF\u30AB\u30CA" -addSample $w Korean "\uB300\uD55C\uBBFC\uAD6D\uC758 \uD55C\uAE00" -addSample $w Russian \ - "\u0420\u0443\u0441\u0441\u043A\u0438\u0439 \u044F\u0437\u044B\u043A" - -## We're done processing, so change things back to normal running... -destroy $w.wait -$w conf -cursor $oldCursor diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/vscale.tcl b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/vscale.tcl @@ -1,46 +0,0 @@ -# vscale.tcl -- -# -# This demonstration script shows an example with a vertical scale. - -if {![info exists widgetDemo]} { - error "This script should be run from the \"widget\" demo." -} - -package require Tk - -set w .vscale -catch {destroy $w} -toplevel $w -wm title $w "Vertical Scale Demonstration" -wm iconname $w "vscale" -positionWindow $w - -label $w.msg -font $font -wraplength 3.5i -justify left -text "An arrow and a vertical scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the size of the arrow." -pack $w.msg -side top -padx .5c - -## See Code / Dismiss buttons -set btns [addSeeDismiss $w.buttons $w] -pack $btns -side bottom -fill x - -frame $w.frame -borderwidth 10 -pack $w.frame - -scale $w.frame.scale -orient vertical -length 284 -from 0 -to 250 \ - -command "setHeight $w.frame.canvas" -tickinterval 50 -canvas $w.frame.canvas -width 50 -height 50 -bd 0 -highlightthickness 0 -$w.frame.canvas create polygon 0 0 1 1 2 2 -fill SeaGreen3 -tags poly -$w.frame.canvas create line 0 0 1 1 2 2 0 0 -fill black -tags line -frame $w.frame.right -borderwidth 15 -pack $w.frame.scale -side left -anchor ne -pack $w.frame.canvas -side left -anchor nw -fill y -$w.frame.scale set 75 - -proc setHeight {w height} { - incr height 21 - set y2 [expr {$height - 30}] - if {$y2 < 21} { - set y2 21 - } - $w coords poly 15 20 35 20 35 $y2 45 $y2 25 $height 5 $y2 15 $y2 15 20 - $w coords line 15 20 35 20 35 $y2 45 $y2 25 $height 5 $y2 15 $y2 15 20 -} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/widget b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/widget @@ -1,721 +0,0 @@ -#!/bin/sh -# the next line restarts using wish \ -exec wish8.6 "$0" ${1+"$@"} - -# widget -- -# This script demonstrates the various widgets provided by Tk, along with many -# of the features of the Tk toolkit. This file only contains code to generate -# the main window for the application, which invokes individual -# demonstrations. The code for the actual demonstrations is contained in -# separate ".tcl" files is this directory, which are sourced by this script as -# needed. - -package require Tk 8.5 -package require msgcat - -eval destroy [winfo child .] -set tk_demoDirectory [file join [pwd] [file dirname [info script]]] -::msgcat::mcload $tk_demoDirectory -namespace import ::msgcat::mc -wm title . [mc "Widget Demonstration"] -if {[tk windowingsystem] eq "x11"} { - # This won't work everywhere, but there's no other way in core Tk at the - # moment to display a coloured icon. - image create photo TclPowered \ - -file [file join $tk_library images logo64.gif] - wm iconwindow . [toplevel ._iconWindow] - pack [label ._iconWindow.i -image TclPowered] - wm iconname . [mc "tkWidgetDemo"] -} - -if {"defaultFont" ni [font names]} { - # TIP #145 defines some standard named fonts - if {"TkDefaultFont" in [font names] && "TkFixedFont" in [font names]} { - # FIX ME: the following technique of cloning the font to copy it works - # fine but means that if the system font is changed by Tk - # cannot update the copied font. font alias might be useful - # here -- or fix the app to use TkDefaultFont etc. - font create mainFont {*}[font configure TkDefaultFont] - font create fixedFont {*}[font configure TkFixedFont] - font create boldFont {*}[font configure TkDefaultFont] -weight bold - font create titleFont {*}[font configure TkDefaultFont] -weight bold - font create statusFont {*}[font configure TkDefaultFont] - font create varsFont {*}[font configure TkDefaultFont] - if {[tk windowingsystem] eq "aqua"} { - font configure titleFont -size 17 - } - } else { - font create mainFont -family Helvetica -size 12 - font create fixedFont -family Courier -size 10 - font create boldFont -family Helvetica -size 12 -weight bold - font create titleFont -family Helvetica -size 18 -weight bold - font create statusFont -family Helvetica -size 10 - font create varsFont -family Helvetica -size 14 - } -} - -set widgetDemo 1 -set font mainFont - -image create photo ::img::refresh -format GIF -data { - R0lGODlhEAAQAJEDAP///wAAACpnKv///yH5BAEAAAMALAAAAAAQABAAAAI63IKp - xgcPH2ouwgBCw1HIxHCQ4F3hSJKmwZXqWrmWxj7lKJ2dndcon9EBUq+gz3brVXAR - 2tICU0gXBQA7 -} - -image create photo ::img::view -format GIF -data { - R0lGODlhEAAQAKIHAP///wwMDAAAAMDAwNnZ2SYmJmZmZv///yH5BAEAAAcALAAA - AAAQABAAAANMKLos90+ASamDRxJCgw9YVnlDOXiQBgRDBRgHKE6sW8QR3doPKK27 - yg33q/GIOhdg6OsEJzeZykiBSUcs06e56Xx6np8ScIkFGuhQAgA7 -} - -image create photo ::img::delete -format GIF -data { - R0lGODlhEAAQAIABAIQAAP///yH5BAEAAAEALAAAAAAQABAAAAIjjI+pmwAc3HGy - PUSvqYpuvWQg40FfSVacBa5nN6JYDI3mzRQAOw== -} - -image create photo ::img::print -format GIF -data { - R0lGODlhEAAQALMKAAAAAP///52VunNkl8C82Yl+qldBgq+pyrOzs1fYAP///wAA - AAAAAAAAAAAAAAAAACH5BAEAAAoALAAAAAAQABAAAARGUMlJKwU4AztB+ODGeUiJ - fGLlgeEYmGWQXmx7aXgmAUTv/74N4EAsGhOJg1DAbDqbwoJ0Sp0KB9isNis0eL/g - ryhH5pgnEQA7 -} - -# Note that this is run through the message catalog! This is because this is -# actually an image of a word. -image create photo ::img::new -format GIF -data [mc { - R0lGODlhHgAOALMPALMAANyIiOu7u8dEROaqqvru7sxVVeGZmbgREfXd3b0iItZ3 - d8IzM9FmZvDMzP///yH5BAEAAA8ALAAAAAAeAA4AAASa8MlJq7046827WVOCHEkw - nANhUgJlEBIABJIwL3K+4IcUALCHjfbItYZDSgJgkBiYPmBMAUAkkLPKs/BAyLgM - wAQwOAAY2ByCaw4QAFQSoDEePJ6DmU1xInYZTw5nOEFFdgVUelkVDTIMd3AKFGQ1 - MgI2AwEmQW8APZ0gdRONAks5nhIFVVxdAAkUAS2pAVwFl7ITB4UqHb0XEQA7 -}] - -#---------------------------------------------------------------- -# The code below create the main window, consisting of a menu bar and a text -# widget that explains how to use the program, plus lists all of the demos as -# hypertext items. -#---------------------------------------------------------------- - -menu .menuBar -tearoff 0 - -if {[tk windowingsystem] ne "aqua"} { - # This is a tk-internal procedure to make i18n easier - ::tk::AmpMenuArgs .menuBar add cascade -label [mc "&File"] \ - -menu .menuBar.file - menu .menuBar.file -tearoff 0 - ::tk::AmpMenuArgs .menuBar.file add command -label [mc "&About..."] \ - -command {tkAboutDialog} -accelerator [mc "<F1>"] - bind . <F1> {tkAboutDialog} - .menuBar.file add sep - if {[string match win* [tk windowingsystem]]} { - # Windows doesn't usually have a Meta key - ::tk::AmpMenuArgs .menuBar.file add command -label [mc "&Quit"] \ - -command {exit} -accelerator [mc "Ctrl+Q"] - bind . <[mc "Control-q"]> {exit} - } else { - ::tk::AmpMenuArgs .menuBar.file add command -label [mc "&Quit"] \ - -command {exit} -accelerator [mc "Meta-Q"] - bind . <[mc "Meta-q"]> {exit} - } -} - -. configure -menu .menuBar - -ttk::frame .statusBar -ttk::label .statusBar.lab -text " " -anchor w -if {[tk windowingsystem] eq "aqua"} { - ttk::separator .statusBar.sep - pack .statusBar.sep -side top -expand yes -fill x -pady 0 -} -pack .statusBar.lab -side left -padx 2 -expand yes -fill both -if {[tk windowingsystem] ne "aqua"} { - ttk::sizegrip .statusBar.foo - pack .statusBar.foo -side left -padx 2 -} -pack .statusBar -side bottom -fill x -pady 2 - -set textheight 30 -catch { - set textheight [expr { - ([winfo screenheight .] * 0.7) / - [font metrics mainFont -displayof . -linespace] - }] -} - -ttk::frame .textFrame -ttk::scrollbar .s -orient vertical -command {.t yview} -takefocus 1 -pack .s -in .textFrame -side right -fill y -text .t -yscrollcommand {.s set} -wrap word -width 70 -height $textheight \ - -font mainFont -setgrid 1 -highlightthickness 0 \ - -padx 4 -pady 2 -takefocus 0 -pack .t -in .textFrame -expand y -fill both -padx 1 -pack .textFrame -expand yes -fill both -if {[tk windowingsystem] eq "aqua"} { - pack configure .statusBar.lab -padx {10 18} -pady {4 6} - pack configure .statusBar -pady 0 - .t configure -padx 10 -pady 0 -} - -# Create a bunch of tags to use in the text widget, such as those for section -# titles and demo descriptions. Also define the bindings for tags. - -.t tag configure title -font titleFont -.t tag configure subtitle -font titleFont -.t tag configure bold -font boldFont -if {[tk windowingsystem] eq "aqua"} { - .t tag configure title -spacing1 8 - .t tag configure subtitle -spacing3 3 -} - -# We put some "space" characters to the left and right of each demo -# description so that the descriptions are highlighted only when the mouse -# cursor is right over them (but not when the cursor is to their left or -# right). -# -.t tag configure demospace -lmargin1 1c -lmargin2 1c - -if {[winfo depth .] == 1} { - .t tag configure demo -lmargin1 1c -lmargin2 1c \ - -underline 1 - .t tag configure visited -lmargin1 1c -lmargin2 1c \ - -underline 1 - .t tag configure hot -background black -foreground white -} else { - .t tag configure demo -lmargin1 1c -lmargin2 1c \ - -foreground blue -underline 1 - .t tag configure visited -lmargin1 1c -lmargin2 1c \ - -foreground #303080 -underline 1 - .t tag configure hot -foreground red -underline 1 -} -.t tag bind demo <ButtonRelease-1> { - invoke [.t index {@%x,%y}] -} -set lastLine "" -.t tag bind demo <Enter> { - set lastLine [.t index {@%x,%y linestart}] - .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" - .t config -cursor [::ttk::cursor link] - showStatus [.t index {@%x,%y}] -} -.t tag bind demo <Leave> { - .t tag remove hot 1.0 end - .t config -cursor [::ttk::cursor text] - .statusBar.lab config -text "" -} -.t tag bind demo <Motion> { - set newLine [.t index {@%x,%y linestart}] - if {$newLine ne $lastLine} { - .t tag remove hot 1.0 end - set lastLine $newLine - - set tags [.t tag names {@%x,%y}] - set i [lsearch -glob $tags demo-*] - if {$i >= 0} { - .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" - } - } - showStatus [.t index {@%x,%y}] -} - -############################################################################## -# Create the text for the text widget. - -# addFormattedText -- -# -# Add formatted text (but not hypertext) to the text widget after first -# passing it through the message catalog to allow for localization. -# Lines starting with @@ are formatting directives (insert title, insert -# demo hyperlink, begin newline, or change style) and all other lines -# are literal strings to be inserted. Substitutions are performed, -# allowing processing pieces through the message catalog. Blank lines -# are ignored. -# -proc addFormattedText {formattedText} { - set style normal - set isNL 1 - set demoCount 0 - set new 0 - foreach line [split $formattedText \n] { - set line [string trim $line] - if {$line eq ""} { - continue - } - if {[string match @@* $line]} { - set data [string range $line 2 end] - set key [lindex $data 0] - set values [lrange $data 1 end] - switch -exact -- $key { - title { - .t insert end [mc $values]\n title \n normal - } - newline { - .t insert end \n $style - set isNL 1 - } - subtitle { - .t insert end "\n" {} [mc $values] subtitle \ - " \n " demospace - set demoCount 0 - } - demo { - set description [lassign $values name] - .t insert end "[incr demoCount]. [mc $description]" \ - [list demo demo-$name] - if {$new} { - .t image create end -image ::img::new -padx 5 - set new 0 - } - .t insert end " \n " demospace - } - new { - set new 1 - } - default { - set style $key - } - } - continue - } - if {!$isNL} { - .t insert end " " $style - } - set isNL 0 - .t insert end [mc $line] $style - } -} - -addFormattedText { - @@title Tk Widget Demonstrations - - This application provides a front end for several short scripts - that demonstrate what you can do with Tk widgets. Each of the - numbered lines below describes a demonstration; you can click on - it to invoke the demonstration. Once the demonstration window - appears, you can click the - @@bold - See Code - @@normal - button to see the Tcl/Tk code that created the demonstration. If - you wish, you can edit the code and click the - @@bold - Rerun Demo - @@normal - button in the code window to reinvoke the demonstration with the - modified code. - @@newline - - @@subtitle Labels, buttons, checkbuttons, and radiobuttons - @@demo label Labels (text and bitmaps) - @@demo unicodeout Labels and UNICODE text - @@demo button Buttons - @@demo check Check-buttons (select any of a group) - @@demo radio Radio-buttons (select one of a group) - @@demo puzzle A 15-puzzle game made out of buttons - @@demo icon Iconic buttons that use bitmaps - @@demo image1 Two labels displaying images - @@demo image2 A simple user interface for viewing images - @@demo labelframe Labelled frames - @@demo ttkbut The simple Themed Tk widgets - - @@subtitle Listboxes and Trees - @@demo states The 50 states - @@demo colors Colors: change the color scheme for the application - @@demo sayings A collection of famous and infamous sayings - @@demo mclist A multi-column list of countries - @@demo tree A directory browser tree - - @@subtitle Entries, Spin-boxes and Combo-boxes - @@demo entry1 Entries without scrollbars - @@demo entry2 Entries with scrollbars - @@demo entry3 Validated entries and password fields - @@demo spin Spin-boxes - @@demo combo Combo-boxes - @@demo form Simple Rolodex-like form - - @@subtitle Text - @@demo text Basic editable text - @@demo style Text display styles - @@demo bind Hypertext (tag bindings) - @@demo twind A text widget with embedded windows and other features - @@demo search A search tool built with a text widget - @@demo textpeer Peering text widgets - - @@subtitle Canvases - @@demo items The canvas item types - @@demo plot A simple 2-D plot - @@demo ctext Text items in canvases - @@demo arrow An editor for arrowheads on canvas lines - @@demo ruler A ruler with adjustable tab stops - @@demo floor A building floor plan - @@demo cscroll A simple scrollable canvas - @@demo knightstour A Knight's tour of the chess board - - @@subtitle Scales and Progress Bars - @@demo hscale Horizontal scale - @@demo vscale Vertical scale - @@new - @@demo ttkscale Themed scale linked to a label with traces - @@demo ttkprogress Progress bar - - @@subtitle Paned Windows and Notebooks - @@demo paned1 Horizontal paned window - @@demo paned2 Vertical paned window - @@demo ttkpane Themed nested panes - @@demo ttknote Notebook widget - - @@subtitle Menus and Toolbars - @@demo menu Menus and cascades (sub-menus) - @@demo menubu Menu-buttons - @@demo ttkmenu Themed menu buttons - @@demo toolbar Themed toolbar - - @@subtitle Common Dialogs - @@demo msgbox Message boxes - @@demo filebox File selection dialog - @@demo clrpick Color picker - @@demo fontchoose Font selection dialog - - @@subtitle Animation - @@demo anilabel Animated labels - @@demo aniwave Animated wave - @@demo pendulum Pendulum simulation - @@demo goldberg A celebration of Rube Goldberg - - @@subtitle Miscellaneous - @@demo bitmap The built-in bitmaps - @@demo dialog1 A dialog box with a local grab - @@demo dialog2 A dialog box with a global grab -} - -############################################################################## - -.t configure -state disabled -focus .s - -# addSeeDismiss -- -# Add "See Code" and "Dismiss" button frame, with optional "See Vars" -# -# Arguments: -# w - The name of the frame to use. - -proc addSeeDismiss {w show {vars {}} {extra {}}} { - ## See Code / Dismiss buttons - ttk::frame $w - ttk::separator $w.sep - #ttk::frame $w.sep -height 2 -relief sunken - grid $w.sep -columnspan 4 -row 0 -sticky ew -pady 2 - ttk::button $w.dismiss -text [mc "Dismiss"] \ - -image ::img::delete -compound left \ - -command [list destroy [winfo toplevel $w]] - ttk::button $w.code -text [mc "See Code"] \ - -image ::img::view -compound left \ - -command [list showCode $show] - set buttons [list x $w.code $w.dismiss] - if {[llength $vars]} { - ttk::button $w.vars -text [mc "See Variables"] \ - -image ::img::view -compound left \ - -command [concat [list showVars $w.dialog] $vars] - set buttons [linsert $buttons 1 $w.vars] - } - if {$extra ne ""} { - set buttons [linsert $buttons 1 [uplevel 1 $extra]] - } - grid {*}$buttons -padx 4 -pady 4 - grid columnconfigure $w 0 -weight 1 - if {[tk windowingsystem] eq "aqua"} { - foreach b [lrange $buttons 1 end] {$b configure -takefocus 0} - grid configure $w.sep -pady 0 - grid configure {*}$buttons -pady {10 12} - grid configure [lindex $buttons 1] -padx {16 4} - grid configure [lindex $buttons end] -padx {4 18} - } - return $w -} - -# positionWindow -- -# This procedure is invoked by most of the demos to position a new demo -# window. -# -# Arguments: -# w - The name of the window to position. - -proc positionWindow w { - wm geometry $w +300+300 -} - -# showVars -- -# Displays the values of one or more variables in a window, and updates the -# display whenever any of the variables changes. -# -# Arguments: -# w - Name of new window to create for display. -# args - Any number of names of variables. - -proc showVars {w args} { - catch {destroy $w} - toplevel $w - if {[tk windowingsystem] eq "x11"} {wm attributes $w -type dialog} - wm title $w [mc "Variable values"] - - set b [ttk::frame $w.frame] - grid $b -sticky news - set f [ttk::labelframe $b.title -text [mc "Variable values:"]] - foreach var $args { - ttk::label $f.n$var -text "$var:" -anchor w - ttk::label $f.v$var -textvariable $var -anchor w - grid $f.n$var $f.v$var -padx 2 -pady 2 -sticky w - } - ttk::button $b.ok -text [mc "OK"] \ - -command [list destroy $w] -default active - bind $w <Return> [list $b.ok invoke] - bind $w <Escape> [list $b.ok invoke] - - grid $f -sticky news -padx 4 - grid $b.ok -sticky e -padx 4 -pady {6 4} - if {[tk windowingsystem] eq "aqua"} { - $b.ok configure -takefocus 0 - grid configure $b.ok -pady {10 12} -padx {16 18} - grid configure $f -padx 10 -pady {10 0} - } - grid columnconfig $f 1 -weight 1 - grid rowconfigure $f 100 -weight 1 - grid columnconfig $b 0 -weight 1 - grid rowconfigure $b 0 -weight 1 - grid columnconfig $w 0 -weight 1 - grid rowconfigure $w 0 -weight 1 -} - -# invoke -- -# This procedure is called when the user clicks on a demo description. It is -# responsible for invoking the demonstration. -# -# Arguments: -# index - The index of the character that the user clicked on. - -proc invoke index { - global tk_demoDirectory - set tags [.t tag names $index] - set i [lsearch -glob $tags demo-*] - if {$i < 0} { - return - } - set cursor [.t cget -cursor] - .t configure -cursor [::ttk::cursor busy] - update - set demo [string range [lindex $tags $i] 5 end] - uplevel 1 [list source [file join $tk_demoDirectory $demo.tcl]] - update - .t configure -cursor $cursor - - .t tag add visited "$index linestart +1 chars" "$index lineend -1 chars" -} - -# showStatus -- -# -# Show the name of the demo program in the status bar. This procedure is -# called when the user moves the cursor over a demo description. -# -proc showStatus index { - set tags [.t tag names $index] - set i [lsearch -glob $tags demo-*] - set cursor [.t cget -cursor] - if {$i < 0} { - .statusBar.lab config -text " " - set newcursor [::ttk::cursor text] - } else { - set demo [string range [lindex $tags $i] 5 end] - .statusBar.lab config -text [mc "Run the \"%s\" sample program" $demo] - set newcursor [::ttk::cursor link] - } - if {$cursor ne $newcursor} { - .t config -cursor $newcursor - } -} - -# evalShowCode -- -# -# Arguments: -# w - Name of text widget containing code to eval - -proc evalShowCode {w} { - set code [$w get 1.0 end-1c] - uplevel #0 $code -} - -# showCode -- -# This procedure creates a toplevel window that displays the code for a -# demonstration and allows it to be edited and reinvoked. -# -# Arguments: -# w - The name of the demonstration's window, which can be used to -# derive the name of the file containing its code. - -proc showCode w { - global tk_demoDirectory - set file [string range $w 1 end].tcl - set top .code - if {![winfo exists $top]} { - toplevel $top - if {[tk windowingsystem] eq "x11"} {wm attributes $top -type dialog} - - set t [frame $top.f] - set text [text $t.text -font fixedFont -height 24 -wrap word \ - -xscrollcommand [list $t.xscroll set] \ - -yscrollcommand [list $t.yscroll set] \ - -setgrid 1 -highlightthickness 0 -pady 2 -padx 3] - ttk::scrollbar $t.xscroll -command [list $t.text xview] \ - -orient horizontal - ttk::scrollbar $t.yscroll -command [list $t.text yview] \ - -orient vertical - - grid $t.text $t.yscroll -sticky news - #grid $t.xscroll - grid rowconfigure $t 0 -weight 1 - grid columnconfig $t 0 -weight 1 - - set btns [ttk::frame $top.btns] - ttk::separator $btns.sep - grid $btns.sep -columnspan 4 -row 0 -sticky ew -pady 2 - ttk::button $btns.dismiss -text [mc "Dismiss"] \ - -default active -command [list destroy $top] \ - -image ::img::delete -compound left - ttk::button $btns.print -text [mc "Print Code"] \ - -command [list printCode $text $file] \ - -image ::img::print -compound left - ttk::button $btns.rerun -text [mc "Rerun Demo"] \ - -command [list evalShowCode $text] \ - -image ::img::refresh -compound left - set buttons [list x $btns.rerun $btns.print $btns.dismiss] - grid {*}$buttons -padx 4 -pady 4 - grid columnconfigure $btns 0 -weight 1 - if {[tk windowingsystem] eq "aqua"} { - foreach b [lrange $buttons 1 end] {$b configure -takefocus 0} - grid configure $btns.sep -pady 0 - grid configure {*}$buttons -pady {10 12} - grid configure [lindex $buttons 1] -padx {16 4} - grid configure [lindex $buttons end] -padx {4 18} - } - grid $t -sticky news - grid $btns -sticky ew - grid rowconfigure $top 0 -weight 1 - grid columnconfig $top 0 -weight 1 - - bind $top <Return> { - if {[winfo class %W] ne "Text"} { .code.btns.dismiss invoke } - } - bind $top <Escape> [bind $top <Return>] - } else { - wm deiconify $top - raise $top - } - wm title $top [mc "Demo code: %s" [file join $tk_demoDirectory $file]] - wm iconname $top $file - set id [open [file join $tk_demoDirectory $file]] - $top.f.text delete 1.0 end - $top.f.text insert 1.0 [read $id] - $top.f.text mark set insert 1.0 - close $id -} - -# printCode -- -# Prints the source code currently displayed in the See Code dialog. Much -# thanks to Arjen Markus for this. -# -# Arguments: -# w - Name of text widget containing code to print -# file - Name of the original file (implicitly for title) - -proc printCode {w file} { - set code [$w get 1.0 end-1c] - - set dir "." - if {[info exists ::env(HOME)]} { - set dir "$::env(HOME)" - } - if {[info exists ::env(TMP)]} { - set dir $::env(TMP) - } - if {[info exists ::env(TEMP)]} { - set dir $::env(TEMP) - } - - set filename [file join $dir "tkdemo-$file"] - set outfile [open $filename "w"] - puts $outfile $code - close $outfile - - switch -- $::tcl_platform(platform) { - unix { - if {[catch {exec lp -c $filename} msg]} { - tk_messageBox -title "Print spooling failure" \ - -message "Print spooling probably failed: $msg" - } - } - windows { - if {[catch {PrintTextWin32 $filename} msg]} { - tk_messageBox -title "Print spooling failure" \ - -message "Print spooling probably failed: $msg" - } - } - default { - tk_messageBox -title "Operation not Implemented" \ - -message "Wow! Unknown platform: $::tcl_platform(platform)" - } - } - - # - # Be careful to throw away the temporary file in a gentle manner ... - # - if {[file exists $filename]} { - catch {file delete $filename} - } -} - -# PrintTextWin32 -- -# Print a file under Windows using all the "intelligence" necessary -# -# Arguments: -# filename - Name of the file -# -# Note: -# Taken from the Wiki page by Keith Vetter, "Printing text files under -# Windows". -# Note: -# Do not execute the command in the background: that way we can dispose of the -# file smoothly. -# -proc PrintTextWin32 {filename} { - package require registry - set app [auto_execok notepad.exe] - set pcmd "$app /p %1" - catch { - set app [registry get {HKEY_CLASSES_ROOT\.txt} {}] - set pcmd [registry get \ - {HKEY_CLASSES_ROOT\\$app\\shell\\print\\command} {}] - } - - regsub -all {%1} $pcmd $filename pcmd - puts $pcmd - - regsub -all {\\} $pcmd {\\\\} pcmd - set command "[auto_execok start] /min $pcmd" - eval exec $command -} - -# tkAboutDialog -- -# -# Pops up a message box with an "about" message -# -proc tkAboutDialog {} { - tk_messageBox -icon info -type ok -title [mc "About Widget Demo"] \ - -message [mc "Tk widget demonstration application"] -detail \ -"[mc "Copyright \u00a9 %s" {1996-1997 Sun Microsystems, Inc.}] -[mc "Copyright \u00a9 %s" {1997-2000 Ajuba Solutions, Inc.}] -[mc "Copyright \u00a9 %s" {2001-2009 Donal K. Fellows}] -[mc "Copyright \u00a9 %s" {2002-2007 Daniel A. Steffen}]" -} - -# Local Variables: -# mode: tcl -# End: diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/images/logo100.gif b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/images/logo100.gif Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tkConfig.sh b/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tkConfig.sh @@ -1,97 +0,0 @@ -# tkConfig.sh -- -# -# This shell script (for sh) is generated automatically by Tk's -# configure script. It will create shell variables for most of -# the configuration options discovered by the configure script. -# This script is intended to be included by the configure scripts -# for Tk extensions so that they don't have to figure this all -# out for themselves. This file does not duplicate information -# already provided by tclConfig.sh, so you may need to use that -# file in addition to this one. -# -# The information in this file is specific to a single platform. - -# Tk's version number. -TK_VERSION='8.6' -TK_MAJOR_VERSION='8' -TK_MINOR_VERSION='6' -TK_PATCH_LEVEL='.8' - -# -D flags for use with the C compiler. -TK_DEFS='-DPACKAGE_NAME=\"tk\" -DPACKAGE_TARNAME=\"tk\" -DPACKAGE_VERSION=\"8.6\" -DPACKAGE_STRING=\"tk\ 8.6\" -DPACKAGE_BUGREPORT=\"\" -DSTDC_HEADERS=1 -DHAVE_SYS_TYPES_H=1 -DHAVE_SYS_STAT_H=1 -DHAVE_STDLIB_H=1 -DHAVE_STRING_H=1 -DHAVE_MEMORY_H=1 -DHAVE_STRINGS_H=1 -DHAVE_INTTYPES_H=1 -DHAVE_STDINT_H=1 -DHAVE_UNISTD_H=1 -DUSE_THREAD_ALLOC=1 -D_REENTRANT=1 -D_THREAD_SAFE=1 -DHAVE_PTHREAD_ATTR_SETSTACKSIZE=1 -DHAVE_PTHREAD_ATFORK=1 -DTCL_THREADS=1 -DMODULE_SCOPE=extern\ __attribute__\(\(__visibility__\(\"hidden\"\)\)\) -DHAVE_HIDDEN=1 -DMAC_OSX_TCL=1 -DHAVE_COREFOUNDATION=1 -DHAVE_CAST_TO_UNION=1 -DTCL_SHLIB_EXT=\".dylib\" -DNDEBUG=1 -DTCL_CFG_OPTIMIZED=1 -DTCL_WIDE_INT_IS_LONG=1 -DHAVE_SYS_TIME_H=1 -DTIME_WITH_SYS_TIME=1 -DHAVE_INTPTR_T=1 -DHAVE_UINTPTR_T=1 -DHAVE_PW_GECOS=1 -DHAVE_AVAILABILITYMACROS_H=1 -DHAVE_WEAK_IMPORT=1 -D_DARWIN_C_SOURCE=1 -DMAC_OSX_TK=1 ' - -# Flag, 1: we built a shared lib, 0 we didn't -TK_SHARED_BUILD=1 - - -# TK_DBGX used to be used to distinguish debug vs. non-debug builds. -# This was a righteous pain so the core doesn't do that any more. -TK_DBGX= - -# The name of the Tk library (may be either a .a file or a shared library): -TK_LIB_FILE='libtk8.6.dylib' - -# Additional libraries to use when linking Tk. -TK_LIBS=' -lpthread -framework CoreFoundation -framework Cocoa -framework Carbon -framework IOKit -lz -lpthread -framework CoreFoundation ' - -# Top-level directory in which Tk's platform-independent files are -# installed. -TK_PREFIX='/usr/local' - -# Top-level directory in which Tk's platform-specific files (e.g. -# executables) are installed. -TK_EXEC_PREFIX='/usr/local' - -# -I switch(es) to use to make all of the X11 include files accessible: -TK_XINCLUDES='' - -# Linker switch(es) to use to link with the X11 library archive. -TK_XLIBSW='' - -# -l flag to pass to the linker to pick up the Tk library -TK_LIB_FLAG='-ltk8.6' - -# String to pass to linker to pick up the Tk library from its -# build directory. -TK_BUILD_LIB_SPEC='-L/private/tmp/_py/_bld/tk8.6.8/unix -ltk8.6' - -# String to pass to linker to pick up the Tk library from its -# installed directory. -TK_LIB_SPEC='-L/Library/Frameworks/Python.framework/Versions/3.7/lib -ltk8.6' - -# String to pass to the compiler so that an extension can -# find installed Tk headers. -TK_INCLUDE_SPEC='-I/usr/local/include' - -# Location of the top-level source directory from which Tk was built. -# This is the directory that contains a README file as well as -# subdirectories such as generic, unix, etc. If Tk was compiled in a -# different place than the directory containing the source files, this -# points to the location of the sources, not the location where Tk was -# compiled. -TK_SRC_DIR='/private/tmp/_py/_bld/tk8.6.8' - -# Needed if you want to make a 'fat' shared library library -# containing tk objects or link a different wish. -TK_CC_SEARCH_FLAGS='' -TK_LD_SEARCH_FLAGS='' - -# The name of the Tk stub library (.a): -TK_STUB_LIB_FILE='libtkstub8.6.a' - -# -l flag to pass to the linker to pick up the Tk stub library -TK_STUB_LIB_FLAG='-ltkstub8.6' - -# String to pass to linker to pick up the Tk stub library from its -# build directory. -TK_BUILD_STUB_LIB_SPEC='-L/private/tmp/_py/_bld/tk8.6.8/unix -ltkstub8.6' - -# String to pass to linker to pick up the Tk stub library from its -# installed directory. -TK_STUB_LIB_SPEC='-L/Library/Frameworks/Python.framework/Versions/3.7/lib -ltkstub8.6' - -# Path to the Tk stub library in the build directory. -TK_BUILD_STUB_LIB_PATH='/private/tmp/_py/_bld/tk8.6.8/unix/libtkstub8.6.a' - -# Path to the Tk stub library in the install directory. -TK_STUB_LIB_PATH='/Library/Frameworks/Python.framework/Versions/3.7/lib/libtkstub8.6.a' diff --git a/MacOS/figENC b/MacOS/figENC Binary files differ. diff --git a/MacOS/figENC.app/Contents/Info.plist b/MacOS/figENC.app/Contents/Info.plist @@ -0,0 +1,22 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> +<plist version="1.0"> +<dict> + <key>CFBundleDisplayName</key> + <string>figENC_MacOS</string> + <key>CFBundleExecutable</key> + <string>MacOS/figENC_MacOS</string> + <key>CFBundleIconFile</key> + <string>icon-windowed.icns</string> + <key>CFBundleIdentifier</key> + <string>figENC_MacOS</string> + <key>CFBundleInfoDictionaryVersion</key> + <string>6.0</string> + <key>CFBundleName</key> + <string>figENC_MacOS</string> + <key>CFBundlePackageType</key> + <string>APPL</string> + <key>CFBundleShortVersionString</key> + <string>0.0.0</string> +</dict> +</plist> diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/Python b/MacOS/figENC.app/Contents/MacOS/Python Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_bisect.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_bisect.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_blake2.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_blake2.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_bz2.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_bz2.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_cffi_backend.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_cffi_backend.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_codecs_cn.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_codecs_cn.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_codecs_hk.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_codecs_hk.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_codecs_iso2022.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_codecs_iso2022.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_codecs_jp.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_codecs_jp.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_codecs_kr.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_codecs_kr.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_codecs_tw.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_codecs_tw.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_contextvars.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_contextvars.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_ctypes.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_ctypes.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_datetime.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_datetime.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_decimal.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_decimal.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_hashlib.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_hashlib.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_heapq.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_heapq.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_lzma.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_lzma.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_md5.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_md5.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_multibytecodec.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_multibytecodec.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_opcode.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_opcode.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_pickle.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_pickle.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_posixsubprocess.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_posixsubprocess.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_random.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_random.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_scproxy.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_scproxy.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_sha1.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_sha1.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_sha256.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_sha256.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_sha3.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_sha3.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_sha512.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_sha512.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_socket.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_socket.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_ssl.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_ssl.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_struct.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_struct.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_struct/cpython-37m-darwin/sotruct.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_struct/cpython-37m-darwin/sotruct.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/_tkinter.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/_tkinter.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/figENC.app/Contents/MacOS/base_library.zip b/MacOS/figENC.app/Contents/MacOS/base_library.zip Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/binascii.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/binascii.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/figENC.app/Contents/MacOS/cryptography-2.7-py3.7.egg-info b/MacOS/figENC.app/Contents/MacOS/cryptography-2.7-py3.7.egg-info @@ -0,0 +1 @@ +../Resources/cryptography-2.7-py3.7.egg-info +\ No newline at end of file diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/cryptography/hazmat/bindings/_constant_time.abi3.so b/MacOS/figENC.app/Contents/MacOS/cryptography/hazmat/bindings/_constant_time.abi3.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/cryptography/hazmat/bindings/_openssl.abi3.so b/MacOS/figENC.app/Contents/MacOS/cryptography/hazmat/bindings/_openssl.abi3.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/cryptography/hazmat/bindings/_padding.abi3.so b/MacOS/figENC.app/Contents/MacOS/cryptography/hazmat/bindings/_padding.abi3.so Binary files differ. diff --git a/MacOS/figENC.app/Contents/MacOS/figENC_MacOS b/MacOS/figENC.app/Contents/MacOS/figENC_MacOS Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/grp.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/grp.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/libcrypto.1.1.dylib b/MacOS/figENC.app/Contents/MacOS/libcrypto.1.1.dylib Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/libncursesw.5.dylib b/MacOS/figENC.app/Contents/MacOS/libncursesw.5.dylib Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/libssl.1.1.dylib b/MacOS/figENC.app/Contents/MacOS/libssl.1.1.dylib Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/libtcl8.6.dylib b/MacOS/figENC.app/Contents/MacOS/libtcl8.6.dylib Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/libtk8.6.dylib b/MacOS/figENC.app/Contents/MacOS/libtk8.6.dylib Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/math.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/math.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/pyexpat.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/pyexpat.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/readline.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/readline.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/resource.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/resource.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/select.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/select.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/figENC.app/Contents/MacOS/tcl b/MacOS/figENC.app/Contents/MacOS/tcl @@ -0,0 +1 @@ +../Resources/tcl +\ No newline at end of file diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/termios.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/termios.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/figENC.app/Contents/MacOS/tk b/MacOS/figENC.app/Contents/MacOS/tk @@ -0,0 +1 @@ +../Resources/tk +\ No newline at end of file diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/unicodedata.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/unicodedata.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/zlib.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/zlib.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/zlib/cpython-37m-darwin/soib.cpython-37m-darwin.so b/MacOS/figENC.app/Contents/MacOS/zlib/cpython-37m-darwin/soib.cpython-37m-darwin.so Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/AUTHORS.rst b/MacOS/figENC.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/AUTHORS.rst diff --git a/MacOS/deprecated_bundle.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/INSTALLER b/MacOS/figENC.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/INSTALLER diff --git a/MacOS/deprecated_bundle.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/LICENSE b/MacOS/figENC.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/LICENSE diff --git a/MacOS/deprecated_bundle.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/LICENSE.APACHE b/MacOS/figENC.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/LICENSE.APACHE diff --git a/MacOS/deprecated_bundle.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/LICENSE.BSD b/MacOS/figENC.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/LICENSE.BSD diff --git a/MacOS/deprecated_bundle.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/LICENSE.PSF b/MacOS/figENC.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/LICENSE.PSF diff --git a/MacOS/deprecated_bundle.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/METADATA b/MacOS/figENC.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/METADATA diff --git a/MacOS/deprecated_bundle.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/RECORD b/MacOS/figENC.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/RECORD diff --git a/MacOS/deprecated_bundle.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/WHEEL b/MacOS/figENC.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/WHEEL diff --git a/MacOS/deprecated_bundle.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/top_level.txt b/MacOS/figENC.app/Contents/Resources/cryptography-2.7-py3.7.egg-info/top_level.txt diff --git a/MacOS/deprecated_bundle.app/Contents/Resources/icon-windowed.icns b/MacOS/figENC.app/Contents/Resources/icon-windowed.icns Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/auto.tcl b/MacOS/figENC.app/Contents/Resources/tcl/auto.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/clock.tcl b/MacOS/figENC.app/Contents/Resources/tcl/clock.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/ascii.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/ascii.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/big5.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/big5.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp1250.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp1250.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp1251.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp1251.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp1252.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp1252.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp1253.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp1253.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp1254.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp1254.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp1255.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp1255.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp1256.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp1256.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp1257.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp1257.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp1258.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp1258.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp437.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp437.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp737.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp737.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp775.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp775.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp850.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp850.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp852.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp852.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp855.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp855.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp857.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp857.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp860.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp860.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp861.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp861.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp862.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp862.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp863.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp863.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp864.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp864.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp865.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp865.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp866.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp866.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp869.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp869.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp874.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp874.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp932.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp932.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp936.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp936.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp949.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp949.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/cp950.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/cp950.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/dingbats.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/dingbats.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/ebcdic.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/ebcdic.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/euc-cn.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/euc-cn.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/euc-jp.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/euc-jp.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/euc-kr.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/euc-kr.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/gb12345.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/gb12345.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/gb1988.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/gb1988.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/gb2312-raw.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/gb2312-raw.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/gb2312.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/gb2312.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/iso2022-jp.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/iso2022-jp.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/iso2022-kr.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/iso2022-kr.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/iso2022.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/iso2022.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/iso8859-1.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/iso8859-1.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/iso8859-10.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/iso8859-10.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/iso8859-13.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/iso8859-13.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/iso8859-14.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/iso8859-14.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/iso8859-15.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/iso8859-15.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/iso8859-16.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/iso8859-16.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/iso8859-2.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/iso8859-2.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/iso8859-3.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/iso8859-3.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/iso8859-4.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/iso8859-4.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/iso8859-5.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/iso8859-5.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/iso8859-6.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/iso8859-6.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/iso8859-7.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/iso8859-7.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/iso8859-8.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/iso8859-8.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/iso8859-9.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/iso8859-9.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/jis0201.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/jis0201.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/jis0208.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/jis0208.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/jis0212.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/jis0212.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/koi8-r.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/koi8-r.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/koi8-u.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/koi8-u.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/ksc5601.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/ksc5601.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/macCentEuro.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/macCentEuro.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/macCroatian.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/macCroatian.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/macCyrillic.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/macCyrillic.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/macDingbats.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/macDingbats.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/macGreek.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/macGreek.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/macIceland.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/macIceland.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/macJapan.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/macJapan.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/macRoman.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/macRoman.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/macRomania.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/macRomania.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/macThai.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/macThai.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/macTurkish.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/macTurkish.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/macUkraine.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/macUkraine.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/shiftjis.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/shiftjis.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/symbol.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/symbol.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/encoding/tis-620.enc b/MacOS/figENC.app/Contents/Resources/tcl/encoding/tis-620.enc diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/history.tcl b/MacOS/figENC.app/Contents/Resources/tcl/history.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/http1.0/http.tcl b/MacOS/figENC.app/Contents/Resources/tcl/http1.0/http.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/http1.0/pkgIndex.tcl b/MacOS/figENC.app/Contents/Resources/tcl/http1.0/pkgIndex.tcl diff --git a/MacOS/figENC.app/Contents/Resources/tcl/init.tcl b/MacOS/figENC.app/Contents/Resources/tcl/init.tcl @@ -0,0 +1,819 @@ +# init.tcl -- +# +# Default system startup file for Tcl-based applications. Defines +# "unknown" procedure and auto-load facilities. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 Scriptics Corporation. +# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# This test intentionally written in pre-7.5 Tcl +if {[info commands package] == ""} { + error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" +} +package require -exact Tcl 8.5.9 + +# Compute the auto path to use in this interpreter. +# The values on the path come from several locations: +# +# The environment variable TCLLIBPATH +# +# tcl_library, which is the directory containing this init.tcl script. +# [tclInit] (Tcl_Init()) searches around for the directory containing this +# init.tcl and defines tcl_library to that location before sourcing it. +# +# The parent directory of tcl_library. Adding the parent +# means that packages in peer directories will be found automatically. +# +# Also add the directory ../lib relative to the directory where the +# executable is located. This is meant to find binary packages for the +# same architecture as the current executable. +# +# tcl_pkgPath, which is set by the platform-specific initialization routines +# On UNIX it is compiled in +# On Windows, it is not used + +if {![info exists auto_path]} { + if {[info exists env(TCLLIBPATH)]} { + set auto_path $env(TCLLIBPATH) + } else { + set auto_path "" + } +} +namespace eval tcl { + variable Dir + foreach Dir [list $::tcl_library [file dirname $::tcl_library]] { + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + } + set Dir [file join [file dirname [file dirname \ + [info nameofexecutable]]] lib] + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + catch { + foreach Dir $::tcl_pkgPath { + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + } + } + + if {![interp issafe]} { + variable Path [encoding dirs] + set Dir [file join $::tcl_library encoding] + if {$Dir ni $Path} { + lappend Path $Dir + encoding dirs $Path + } + } + + # TIP #255 min and max functions + namespace eval mathfunc { + proc min {args} { + if {![llength $args]} { + return -code error \ + "too few arguments to math function \"min\"" + } + set val Inf + foreach arg $args { + # This will handle forcing the numeric value without + # ruining the internal type of a numeric object + if {[catch {expr {double($arg)}} err]} { + return -code error $err + } + if {$arg < $val} {set val $arg} + } + return $val + } + proc max {args} { + if {![llength $args]} { + return -code error \ + "too few arguments to math function \"max\"" + } + set val -Inf + foreach arg $args { + # This will handle forcing the numeric value without + # ruining the internal type of a numeric object + if {[catch {expr {double($arg)}} err]} { + return -code error $err + } + if {$arg > $val} {set val $arg} + } + return $val + } + namespace export min max + } +} + +# Windows specific end of initialization + +if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { + namespace eval tcl { + proc EnvTraceProc {lo n1 n2 op} { + global env + set x $env($n2) + set env($lo) $x + set env([string toupper $lo]) $x + } + proc InitWinEnv {} { + global env tcl_platform + foreach p [array names env] { + set u [string toupper $p] + if {$u ne $p} { + switch -- $u { + COMSPEC - + PATH { + set temp $env($p) + unset env($p) + set env($u) $temp + trace add variable env($p) write \ + [namespace code [list EnvTraceProc $p]] + trace add variable env($u) write \ + [namespace code [list EnvTraceProc $p]] + } + } + } + } + if {![info exists env(COMSPEC)]} { + set env(COMSPEC) cmd.exe + } + } + InitWinEnv + } +} + +# Setup the unknown package handler + + +if {[interp issafe]} { + package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} +} else { + # Set up search for Tcl Modules (TIP #189). + # and setup platform specific unknown package handlers + if {$tcl_platform(os) eq "Darwin" + && $tcl_platform(platform) eq "unix"} { + package unknown {::tcl::tm::UnknownHandler \ + {::tcl::MacOSXPkgUnknown ::tclPkgUnknown}} + } else { + package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} + } + + # Set up the 'clock' ensemble + + namespace eval ::tcl::clock [list variable TclLibDir $::tcl_library] + + proc ::tcl::initClock {} { + # Auto-loading stubs for 'clock.tcl' + + foreach cmd {add format scan} { + proc ::tcl::clock::$cmd args { + variable TclLibDir + source -encoding utf-8 [file join $TclLibDir clock.tcl] + return [uplevel 1 [info level 0]] + } + } + + rename ::tcl::initClock {} + } + ::tcl::initClock +} + +# Conditionalize for presence of exec. + +if {[namespace which -command exec] eq ""} { + + # Some machines do not have exec. Also, on all + # platforms, safe interpreters do not have exec. + + set auto_noexec 1 +} + +# Define a log command (which can be overwitten to log errors +# differently, specially when stderr is not available) + +if {[namespace which -command tclLog] eq ""} { + proc tclLog {string} { + catch {puts stderr $string} + } +} + +# unknown -- +# This procedure is called when a Tcl command is invoked that doesn't +# exist in the interpreter. It takes the following steps to make the +# command available: +# +# 1. See if the autoload facility can locate the command in a +# Tcl script file. If so, load it and execute it. +# 2. If the command was invoked interactively at top-level: +# (a) see if the command exists as an executable UNIX program. +# If so, "exec" the command. +# (b) see if the command requests csh-like history substitution +# in one of the common forms !!, !<number>, or ^old^new. If +# so, emulate csh's history substitution. +# (c) see if the command is a unique abbreviation for another +# command. If so, invoke the command. +# +# Arguments: +# args - A list whose elements are the words of the original +# command, including the command name. + +proc unknown args { + variable ::tcl::UnknownPending + global auto_noexec auto_noload env tcl_interactive errorInfo errorCode + + if {[info exists errorInfo]} { + set savedErrorInfo $errorInfo + } + if {[info exists errorCode]} { + set savedErrorCode $errorCode + } + + set name [lindex $args 0] + if {![info exists auto_noload]} { + # + # Make sure we're not trying to load the same proc twice. + # + if {[info exists UnknownPending($name)]} { + return -code error "self-referential recursion\ + in \"unknown\" for command \"$name\"" + } + set UnknownPending($name) pending + set ret [catch { + auto_load $name [uplevel 1 {::namespace current}] + } msg opts] + unset UnknownPending($name) + if {$ret != 0} { + dict append opts -errorinfo "\n (autoloading \"$name\")" + return -options $opts $msg + } + if {![array size UnknownPending]} { + unset UnknownPending + } + if {$msg} { + if {[info exists savedErrorCode]} { + set ::errorCode $savedErrorCode + } else { + unset -nocomplain ::errorCode + } + if {[info exists savedErrorInfo]} { + set errorInfo $savedErrorInfo + } else { + unset -nocomplain errorInfo + } + set code [catch {uplevel 1 $args} msg opts] + if {$code == 1} { + # + # Compute stack trace contribution from the [uplevel]. + # Note the dependence on how Tcl_AddErrorInfo, etc. + # construct the stack trace. + # + set errInfo [dict get $opts -errorinfo] + set errCode [dict get $opts -errorcode] + set cinfo $args + if {[string bytelength $cinfo] > 150} { + set cinfo [string range $cinfo 0 150] + while {[string bytelength $cinfo] > 150} { + set cinfo [string range $cinfo 0 end-1] + } + append cinfo ... + } + set tail "\n (\"uplevel\" body line 1)\n invoked\ + from within\n\"uplevel 1 \$args\"" + set expect "$msg\n while executing\n\"$cinfo\"$tail" + if {$errInfo eq $expect} { + # + # The stack has only the eval from the expanded command + # Do not generate any stack trace here. + # + dict unset opts -errorinfo + dict incr opts -level + return -options $opts $msg + } + # + # Stack trace is nested, trim off just the contribution + # from the extra "eval" of $args due to the "catch" above. + # + set last [string last $tail $errInfo] + if {$last + [string length $tail] != [string length $errInfo]} { + # Very likely cannot happen + return -options $opts $msg + } + set errInfo [string range $errInfo 0 $last-1] + set tail "\"$cinfo\"" + set last [string last $tail $errInfo] + if {$last + [string length $tail] != [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo $errInfo $msg + } + set errInfo [string range $errInfo 0 $last-1] + set tail "\n invoked from within\n" + set last [string last $tail $errInfo] + if {$last + [string length $tail] == [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo [string range $errInfo 0 $last-1] $msg + } + set tail "\n while executing\n" + set last [string last $tail $errInfo] + if {$last + [string length $tail] == [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo [string range $errInfo 0 $last-1] $msg + } + return -options $opts $msg + } else { + dict incr opts -level + return -options $opts $msg + } + } + } + + if {([info level] == 1) && ([info script] eq "") + && [info exists tcl_interactive] && $tcl_interactive} { + if {![info exists auto_noexec]} { + set new [auto_execok $name] + if {$new ne ""} { + set redir "" + if {[namespace which -command console] eq ""} { + set redir ">&@stdout <@stdin" + } + uplevel 1 [list ::catch \ + [concat exec $redir $new [lrange $args 1 end]] \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + } + if {$name eq "!!"} { + set newcmd [history event] + } elseif {[regexp {^!(.+)$} $name -> event]} { + set newcmd [history event $event] + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} { + set newcmd [history event -1] + catch {regsub -all -- $old $newcmd $new newcmd} + } + if {[info exists newcmd]} { + tclLog $newcmd + history change $newcmd 0 + uplevel 1 [list ::catch $newcmd \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + + set ret [catch {set candidates [info commands $name*]} msg] + if {$name eq "::"} { + set name "" + } + if {$ret != 0} { + dict append opts -errorinfo \ + "\n (expanding command prefix \"$name\" in unknown)" + return -options $opts $msg + } + # Filter out bogus matches when $name contained + # a glob-special char [Bug 946952] + if {$name eq ""} { + # Handle empty $name separately due to strangeness + # in [string first] (See RFE 1243354) + set cmds $candidates + } else { + set cmds [list] + foreach x $candidates { + if {[string first $name $x] == 0} { + lappend cmds $x + } + } + } + if {[llength $cmds] == 1} { + uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + if {[llength $cmds]} { + return -code error "ambiguous command name \"$name\": [lsort $cmds]" + } + } + return -code error -errorcode [list TCL LOOKUP COMMAND $name] \ + "invalid command name \"$name\"" +} + +# auto_load -- +# Checks a collection of library directories to see if a procedure +# is defined in one of them. If so, it sources the appropriate +# library file to create the procedure. Returns 1 if it successfully +# loaded the procedure, 0 otherwise. +# +# Arguments: +# cmd - Name of the command to find and load. +# namespace (optional) The namespace where the command is being used - must be +# a canonical namespace as returned [namespace current] +# for instance. If not given, namespace current is used. + +proc auto_load {cmd {namespace {}}} { + global auto_index auto_path + + if {$namespace eq ""} { + set namespace [uplevel 1 [list ::namespace current]] + } + set nameList [auto_qualify $cmd $namespace] + # workaround non canonical auto_index entries that might be around + # from older auto_mkindex versions + lappend nameList $cmd + foreach name $nameList { + if {[info exists auto_index($name)]} { + namespace eval :: $auto_index($name) + # There's a couple of ways to look for a command of a given + # name. One is to use + # info commands $name + # Unfortunately, if the name has glob-magic chars in it like * + # or [], it may not match. For our purposes here, a better + # route is to use + # namespace which -command $name + if {[namespace which -command $name] ne ""} { + return 1 + } + } + } + if {![info exists auto_path]} { + return 0 + } + + if {![auto_load_index]} { + return 0 + } + foreach name $nameList { + if {[info exists auto_index($name)]} { + namespace eval :: $auto_index($name) + if {[namespace which -command $name] ne ""} { + return 1 + } + } + } + return 0 +} + +# auto_load_index -- +# Loads the contents of tclIndex files on the auto_path directory +# list. This is usually invoked within auto_load to load the index +# of available commands. Returns 1 if the index is loaded, and 0 if +# the index is already loaded and up to date. +# +# Arguments: +# None. + +proc auto_load_index {} { + variable ::tcl::auto_oldpath + global auto_index auto_path + + if {[info exists auto_oldpath] && ($auto_oldpath eq $auto_path)} { + return 0 + } + set auto_oldpath $auto_path + + # Check if we are a safe interpreter. In that case, we support only + # newer format tclIndex files. + + set issafe [interp issafe] + for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} { + set dir [lindex $auto_path $i] + set f "" + if {$issafe} { + catch {source [file join $dir tclIndex]} + } elseif {[catch {set f [open [file join $dir tclIndex]]}]} { + continue + } else { + set error [catch { + set id [gets $f] + if {$id eq "# Tcl autoload index file, version 2.0"} { + eval [read $f] + } elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} { + while {[gets $f line] >= 0} { + if {([string index $line 0] eq "#") \ + || ([llength $line] != 2)} { + continue + } + set name [lindex $line 0] + set auto_index($name) \ + "source [file join $dir [lindex $line 1]]" + } + } else { + error "[file join $dir tclIndex] isn't a proper Tcl index file" + } + } msg opts] + if {$f ne ""} { + close $f + } + if {$error} { + return -options $opts $msg + } + } + } + return 1 +} + +# auto_qualify -- +# +# Compute a fully qualified names list for use in the auto_index array. +# For historical reasons, commands in the global namespace do not have leading +# :: in the index key. The list has two elements when the command name is +# relative (no leading ::) and the namespace is not the global one. Otherwise +# only one name is returned (and searched in the auto_index). +# +# Arguments - +# cmd The command name. Can be any name accepted for command +# invocations (Like "foo::::bar"). +# namespace The namespace where the command is being used - must be +# a canonical namespace as returned by [namespace current] +# for instance. + +proc auto_qualify {cmd namespace} { + + # count separators and clean them up + # (making sure that foo:::::bar will be treated as foo::bar) + set n [regsub -all {::+} $cmd :: cmd] + + # Ignore namespace if the name starts with :: + # Handle special case of only leading :: + + # Before each return case we give an example of which category it is + # with the following form : + # (inputCmd, inputNameSpace) -> output + + if {[string match ::* $cmd]} { + if {$n > 1} { + # (::foo::bar , *) -> ::foo::bar + return [list $cmd] + } else { + # (::global , *) -> global + return [list [string range $cmd 2 end]] + } + } + + # Potentially returning 2 elements to try : + # (if the current namespace is not the global one) + + if {$n == 0} { + if {$namespace eq "::"} { + # (nocolons , ::) -> nocolons + return [list $cmd] + } else { + # (nocolons , ::sub) -> ::sub::nocolons nocolons + return [list ${namespace}::$cmd $cmd] + } + } elseif {$namespace eq "::"} { + # (foo::bar , ::) -> ::foo::bar + return [list ::$cmd] + } else { + # (foo::bar , ::sub) -> ::sub::foo::bar ::foo::bar + return [list ${namespace}::$cmd ::$cmd] + } +} + +# auto_import -- +# +# Invoked during "namespace import" to make see if the imported commands +# reside in an autoloaded library. If so, the commands are loaded so +# that they will be available for the import links. If not, then this +# procedure does nothing. +# +# Arguments - +# pattern The pattern of commands being imported (like "foo::*") +# a canonical namespace as returned by [namespace current] + +proc auto_import {pattern} { + global auto_index + + # If no namespace is specified, this will be an error case + + if {![string match *::* $pattern]} { + return + } + + set ns [uplevel 1 [list ::namespace current]] + set patternList [auto_qualify $pattern $ns] + + auto_load_index + + foreach pattern $patternList { + foreach name [array names auto_index $pattern] { + if {([namespace which -command $name] eq "") + && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} { + namespace eval :: $auto_index($name) + } + } + } +} + +# auto_execok -- +# +# Returns string that indicates name of program to execute if +# name corresponds to a shell builtin or an executable in the +# Windows search path, or "" otherwise. Builds an associative +# array auto_execs that caches information about previous checks, +# for speed. +# +# Arguments: +# name - Name of a command. + +if {$tcl_platform(platform) eq "windows"} { +# Windows version. +# +# Note that file executable doesn't work under Windows, so we have to +# look for files with .exe, .com, or .bat extensions. Also, the path +# may be in the Path or PATH environment variables, and path +# components are separated with semicolons, not colons as under Unix. +# +proc auto_execok name { + global auto_execs env tcl_platform + + if {[info exists auto_execs($name)]} { + return $auto_execs($name) + } + set auto_execs($name) "" + + set shellBuiltins [list assoc cls copy date del dir echo erase ftype \ + md mkdir mklink move rd ren rename rmdir start time type ver vol] + if {[info exists env(PATHEXT)]} { + # Add an initial ; to have the {} extension check first. + set execExtensions [split ";$env(PATHEXT)" ";"] + } else { + set execExtensions [list {} .com .exe .bat .cmd] + } + + if {[string tolower $name] in $shellBuiltins} { + # When this is command.com for some reason on Win2K, Tcl won't + # exec it unless the case is right, which this corrects. COMSPEC + # may not point to a real file, so do the check. + set cmd $env(COMSPEC) + if {[file exists $cmd]} { + set cmd [file attributes $cmd -shortname] + } + return [set auto_execs($name) [list $cmd /c $name]] + } + + if {[llength [file split $name]] != 1} { + foreach ext $execExtensions { + set file ${name}${ext} + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + return "" + } + + set path "[file dirname [info nameof]];.;" + if {[info exists env(WINDIR)]} { + set windir $env(WINDIR) + } + if {[info exists windir]} { + if {$tcl_platform(os) eq "Windows NT"} { + append path "$windir/system32;" + } + append path "$windir/system;$windir;" + } + + foreach var {PATH Path path} { + if {[info exists env($var)]} { + append path ";$env($var)" + } + } + + foreach ext $execExtensions { + unset -nocomplain checked + foreach dir [split $path {;}] { + # Skip already checked directories + if {[info exists checked($dir)] || ($dir eq "")} { + continue + } + set checked($dir) {} + set file [file join $dir ${name}${ext}] + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + } + return "" +} + +} else { +# Unix version. +# +proc auto_execok name { + global auto_execs env + + if {[info exists auto_execs($name)]} { + return $auto_execs($name) + } + set auto_execs($name) "" + if {[llength [file split $name]] != 1} { + if {[file executable $name] && ![file isdirectory $name]} { + set auto_execs($name) [list $name] + } + return $auto_execs($name) + } + foreach dir [split $env(PATH) :] { + if {$dir eq ""} { + set dir . + } + set file [file join $dir $name] + if {[file executable $file] && ![file isdirectory $file]} { + set auto_execs($name) [list $file] + return $auto_execs($name) + } + } + return "" +} + +} + +# ::tcl::CopyDirectory -- +# +# This procedure is called by Tcl's core when attempts to call the +# filesystem's copydirectory function fail. The semantics of the call +# are that 'dest' does not yet exist, i.e. dest should become the exact +# image of src. If dest does exist, we throw an error. +# +# Note that making changes to this procedure can change the results +# of running Tcl's tests. +# +# Arguments: +# action - "renaming" or "copying" +# src - source directory +# dest - destination directory +proc tcl::CopyDirectory {action src dest} { + set nsrc [file normalize $src] + set ndest [file normalize $dest] + + if {$action eq "renaming"} { + # Can't rename volumes. We could give a more precise + # error message here, but that would break the test suite. + if {$nsrc in [file volumes]} { + return -code error "error $action \"$src\" to\ + \"$dest\": trying to rename a volume or move a directory\ + into itself" + } + } + if {[file exists $dest]} { + if {$nsrc eq $ndest} { + return -code error "error $action \"$src\" to\ + \"$dest\": trying to rename a volume or move a directory\ + into itself" + } + if {$action eq "copying"} { + # We used to throw an error here, but, looking more closely + # at the core copy code in tclFCmd.c, if the destination + # exists, then we should only call this function if -force + # is true, which means we just want to over-write. So, + # the following code is now commented out. + # + # return -code error "error $action \"$src\" to\ + # \"$dest\": file already exists" + } else { + # Depending on the platform, and on the current + # working directory, the directories '.', '..' + # can be returned in various combinations. Anyway, + # if any other file is returned, we must signal an error. + set existing [glob -nocomplain -directory $dest * .*] + lappend existing {*}[glob -nocomplain -directory $dest \ + -type hidden * .*] + foreach s $existing { + if {[file tail $s] ni {. ..}} { + return -code error "error $action \"$src\" to\ + \"$dest\": file already exists" + } + } + } + } else { + if {[string first $nsrc $ndest] != -1} { + set srclen [expr {[llength [file split $nsrc]] - 1}] + set ndest [lindex [file split $ndest] $srclen] + if {$ndest eq [file tail $nsrc]} { + return -code error "error $action \"$src\" to\ + \"$dest\": trying to rename a volume or move a directory\ + into itself" + } + } + file mkdir $dest + } + # Have to be careful to capture both visible and hidden files. + # We will also be more generous to the file system and not + # assume the hidden and non-hidden lists are non-overlapping. + # + # On Unix 'hidden' files begin with '.'. On other platforms + # or filesystems hidden files may have other interpretations. + set filelist [concat [glob -nocomplain -directory $src *] \ + [glob -nocomplain -directory $src -types hidden *]] + + foreach s [lsort -unique $filelist] { + if {[file tail $s] ni {. ..}} { + file copy -force -- $s [file join $dest [file tail $s]] + } + } + return +} diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/af.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/af.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/af_za.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/af_za.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/ar.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/ar.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/ar_in.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/ar_in.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/ar_jo.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/ar_jo.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/ar_lb.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/ar_lb.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/ar_sy.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/ar_sy.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/be.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/be.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/bg.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/bg.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/bn.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/bn.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/bn_in.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/bn_in.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/ca.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/ca.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/cs.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/cs.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/da.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/da.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/de.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/de.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/de_at.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/de_at.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/de_be.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/de_be.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/el.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/el.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/en_au.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/en_au.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/en_be.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/en_be.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/en_bw.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/en_bw.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/en_ca.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/en_ca.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/en_gb.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/en_gb.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/en_hk.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/en_hk.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/en_ie.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/en_ie.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/en_in.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/en_in.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/en_nz.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/en_nz.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/en_ph.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/en_ph.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/en_sg.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/en_sg.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/en_za.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/en_za.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/en_zw.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/en_zw.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/eo.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/eo.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es_ar.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es_ar.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es_bo.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es_bo.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es_cl.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es_cl.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es_co.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es_co.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es_cr.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es_cr.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es_do.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es_do.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es_ec.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es_ec.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es_gt.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es_gt.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es_hn.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es_hn.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es_mx.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es_mx.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es_ni.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es_ni.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es_pa.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es_pa.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es_pe.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es_pe.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es_pr.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es_pr.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es_py.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es_py.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es_sv.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es_sv.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es_uy.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es_uy.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/es_ve.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/es_ve.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/et.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/et.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/eu.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/eu.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/eu_es.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/eu_es.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/fa.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/fa.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/fa_in.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/fa_in.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/fa_ir.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/fa_ir.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/fi.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/fi.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/fo.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/fo.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/fo_fo.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/fo_fo.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/fr.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/fr.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/fr_be.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/fr_be.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/fr_ca.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/fr_ca.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/fr_ch.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/fr_ch.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/ga.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/ga.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/ga_ie.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/ga_ie.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/gl.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/gl.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/gl_es.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/gl_es.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/gv.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/gv.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/gv_gb.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/gv_gb.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/he.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/he.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/hi.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/hi.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/hi_in.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/hi_in.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/hr.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/hr.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/hu.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/hu.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/id.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/id.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/id_id.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/id_id.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/is.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/is.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/it.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/it.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/it_ch.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/it_ch.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/ja.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/ja.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/kl.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/kl.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/kl_gl.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/kl_gl.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/ko.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/ko.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/ko_kr.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/ko_kr.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/kok.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/kok.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/kok_in.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/kok_in.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/kw.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/kw.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/kw_gb.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/kw_gb.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/lt.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/lt.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/lv.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/lv.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/mk.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/mk.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/mr.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/mr.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/mr_in.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/mr_in.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/ms.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/ms.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/ms_my.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/ms_my.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/mt.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/mt.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/nb.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/nb.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/nl.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/nl.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/nl_be.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/nl_be.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/nn.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/nn.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/pl.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/pl.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/pt.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/pt.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/pt_br.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/pt_br.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/ro.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/ro.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/ru.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/ru.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/ru_ua.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/ru_ua.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/sh.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/sh.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/sk.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/sk.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/sl.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/sl.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/sq.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/sq.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/sr.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/sr.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/sv.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/sv.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/sw.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/sw.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/ta.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/ta.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/ta_in.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/ta_in.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/te.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/te.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/te_in.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/te_in.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/th.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/th.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/tr.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/tr.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/uk.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/uk.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/vi.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/vi.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/zh.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/zh.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/zh_cn.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/zh_cn.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/zh_hk.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/zh_hk.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/zh_sg.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/zh_sg.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/msgs/zh_tw.msg b/MacOS/figENC.app/Contents/Resources/tcl/msgs/zh_tw.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/opt0.4/optparse.tcl b/MacOS/figENC.app/Contents/Resources/tcl/opt0.4/optparse.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/opt0.4/pkgIndex.tcl b/MacOS/figENC.app/Contents/Resources/tcl/opt0.4/pkgIndex.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/package.tcl b/MacOS/figENC.app/Contents/Resources/tcl/package.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/parray.tcl b/MacOS/figENC.app/Contents/Resources/tcl/parray.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/safe.tcl b/MacOS/figENC.app/Contents/Resources/tcl/safe.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/tclAppInit.c b/MacOS/figENC.app/Contents/Resources/tcl/tclAppInit.c diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/tclIndex b/MacOS/figENC.app/Contents/Resources/tcl/tclIndex diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/tm.tcl b/MacOS/figENC.app/Contents/Resources/tcl/tm.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tcl/tcl8.6/word.tcl b/MacOS/figENC.app/Contents/Resources/tcl/word.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/bgerror.tcl b/MacOS/figENC.app/Contents/Resources/tk/bgerror.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/button.tcl b/MacOS/figENC.app/Contents/Resources/tk/button.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/choosedir.tcl b/MacOS/figENC.app/Contents/Resources/tk/choosedir.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/clrpick.tcl b/MacOS/figENC.app/Contents/Resources/tk/clrpick.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/comdlg.tcl b/MacOS/figENC.app/Contents/Resources/tk/comdlg.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/console.tcl b/MacOS/figENC.app/Contents/Resources/tk/console.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/dialog.tcl b/MacOS/figENC.app/Contents/Resources/tk/dialog.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/entry.tcl b/MacOS/figENC.app/Contents/Resources/tk/entry.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/focus.tcl b/MacOS/figENC.app/Contents/Resources/tk/focus.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/fontchooser.tcl b/MacOS/figENC.app/Contents/Resources/tk/fontchooser.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/iconlist.tcl b/MacOS/figENC.app/Contents/Resources/tk/iconlist.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/icons.tcl b/MacOS/figENC.app/Contents/Resources/tk/icons.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/images/README b/MacOS/figENC.app/Contents/Resources/tk/images/README diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/images/logo.eps b/MacOS/figENC.app/Contents/Resources/tk/images/logo.eps diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/demos/images/tcllogo.gif b/MacOS/figENC.app/Contents/Resources/tk/images/logo100.gif Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/images/logo64.gif b/MacOS/figENC.app/Contents/Resources/tk/images/logo64.gif Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/images/logoLarge.gif b/MacOS/figENC.app/Contents/Resources/tk/images/logoLarge.gif Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/images/logoMed.gif b/MacOS/figENC.app/Contents/Resources/tk/images/logoMed.gif Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/images/pwrdLogo.eps b/MacOS/figENC.app/Contents/Resources/tk/images/pwrdLogo.eps diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/images/pwrdLogo100.gif b/MacOS/figENC.app/Contents/Resources/tk/images/pwrdLogo100.gif Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/images/pwrdLogo150.gif b/MacOS/figENC.app/Contents/Resources/tk/images/pwrdLogo150.gif Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/images/pwrdLogo175.gif b/MacOS/figENC.app/Contents/Resources/tk/images/pwrdLogo175.gif Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/images/pwrdLogo200.gif b/MacOS/figENC.app/Contents/Resources/tk/images/pwrdLogo200.gif Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/images/pwrdLogo75.gif b/MacOS/figENC.app/Contents/Resources/tk/images/pwrdLogo75.gif Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/images/tai-ku.gif b/MacOS/figENC.app/Contents/Resources/tk/images/tai-ku.gif Binary files differ. diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/listbox.tcl b/MacOS/figENC.app/Contents/Resources/tk/listbox.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/megawidget.tcl b/MacOS/figENC.app/Contents/Resources/tk/megawidget.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/menu.tcl b/MacOS/figENC.app/Contents/Resources/tk/menu.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/mkpsenc.tcl b/MacOS/figENC.app/Contents/Resources/tk/mkpsenc.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/msgbox.tcl b/MacOS/figENC.app/Contents/Resources/tk/msgbox.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/msgs/cs.msg b/MacOS/figENC.app/Contents/Resources/tk/msgs/cs.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/msgs/da.msg b/MacOS/figENC.app/Contents/Resources/tk/msgs/da.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/msgs/de.msg b/MacOS/figENC.app/Contents/Resources/tk/msgs/de.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/msgs/el.msg b/MacOS/figENC.app/Contents/Resources/tk/msgs/el.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/msgs/en.msg b/MacOS/figENC.app/Contents/Resources/tk/msgs/en.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/msgs/en_gb.msg b/MacOS/figENC.app/Contents/Resources/tk/msgs/en_gb.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/msgs/eo.msg b/MacOS/figENC.app/Contents/Resources/tk/msgs/eo.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/msgs/es.msg b/MacOS/figENC.app/Contents/Resources/tk/msgs/es.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/msgs/fr.msg b/MacOS/figENC.app/Contents/Resources/tk/msgs/fr.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/msgs/hu.msg b/MacOS/figENC.app/Contents/Resources/tk/msgs/hu.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/msgs/it.msg b/MacOS/figENC.app/Contents/Resources/tk/msgs/it.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/msgs/nl.msg b/MacOS/figENC.app/Contents/Resources/tk/msgs/nl.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/msgs/pl.msg b/MacOS/figENC.app/Contents/Resources/tk/msgs/pl.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/msgs/pt.msg b/MacOS/figENC.app/Contents/Resources/tk/msgs/pt.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/msgs/ru.msg b/MacOS/figENC.app/Contents/Resources/tk/msgs/ru.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/msgs/sv.msg b/MacOS/figENC.app/Contents/Resources/tk/msgs/sv.msg diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/obsolete.tcl b/MacOS/figENC.app/Contents/Resources/tk/obsolete.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/optMenu.tcl b/MacOS/figENC.app/Contents/Resources/tk/optMenu.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/palette.tcl b/MacOS/figENC.app/Contents/Resources/tk/palette.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/panedwindow.tcl b/MacOS/figENC.app/Contents/Resources/tk/panedwindow.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/pkgIndex.tcl b/MacOS/figENC.app/Contents/Resources/tk/pkgIndex.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/safetk.tcl b/MacOS/figENC.app/Contents/Resources/tk/safetk.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/scale.tcl b/MacOS/figENC.app/Contents/Resources/tk/scale.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/scrlbar.tcl b/MacOS/figENC.app/Contents/Resources/tk/scrlbar.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/spinbox.tcl b/MacOS/figENC.app/Contents/Resources/tk/spinbox.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/tclIndex b/MacOS/figENC.app/Contents/Resources/tk/tclIndex diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/tearoff.tcl b/MacOS/figENC.app/Contents/Resources/tk/tearoff.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/text.tcl b/MacOS/figENC.app/Contents/Resources/tk/text.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/tk.tcl b/MacOS/figENC.app/Contents/Resources/tk/tk.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/tkAppInit.c b/MacOS/figENC.app/Contents/Resources/tk/tkAppInit.c diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/tkfbox.tcl b/MacOS/figENC.app/Contents/Resources/tk/tkfbox.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/altTheme.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/altTheme.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/aquaTheme.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/aquaTheme.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/button.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/button.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/clamTheme.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/clamTheme.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/classicTheme.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/classicTheme.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/combobox.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/combobox.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/cursors.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/cursors.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/defaults.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/defaults.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/entry.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/entry.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/fonts.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/fonts.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/menubutton.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/menubutton.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/notebook.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/notebook.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/panedwindow.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/panedwindow.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/progress.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/progress.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/scale.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/scale.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/scrollbar.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/scrollbar.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/sizegrip.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/sizegrip.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/spinbox.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/spinbox.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/treeview.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/treeview.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/ttk.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/ttk.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/utils.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/utils.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/vistaTheme.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/vistaTheme.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/winTheme.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/winTheme.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/ttk/xpTheme.tcl b/MacOS/figENC.app/Contents/Resources/tk/ttk/xpTheme.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/unsupported.tcl b/MacOS/figENC.app/Contents/Resources/tk/unsupported.tcl diff --git a/MacOS/deprecated_bundle.app/Contents/MacOS/tk/tk8.6/xmfbox.tcl b/MacOS/figENC.app/Contents/Resources/tk/xmfbox.tcl
