FAQ | This is a LIVE service | Changelog

Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • ssb22/gradint
  • st822/gradint
2 results
Show changes
Hide whitespace changes
Inline Side-by-side
Showing
with 448 additions and 7915 deletions
charlearn/charlearn.py 0 → 100755
View file @ e16f7a7d
#!/usr/bin/env python
# (should work in either Python 2 or Python 3)
# Character-learning support program
# (C) 2006-2013, 2020 Silas S. Brown. Version 0.3.
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
# Where to find history:
# on GitHub at https://github.com/ssb22/gradint
# and on GitLab at https://gitlab.com/ssb22/gradint
# and on BitBucket https://bitbucket.org/ssb22/gradint
# and at https://gitlab.developers.cam.ac.uk/ssb22/gradint
# and in China: https://gitee.com/ssb22/gradint
listenAddr='127.0.0.1'
firstPortNo=9876
tableFile = "characters.txt" # for first-time setup
knownFile = "known-chars.txt" # ditto
dumpFile = "charlearn-data" # for saving progress
reviseFile = "revise.txt" # for requesting more revision next time (will be deleted after integration into progress)
import sys,os.path
if sys.argv[-1].startswith("--"): gradint = None # (don't need to speak if we're processing options, see at end)
elif os.path.isfile("gradint.py"): import gradint
else: gradint = None # won't speak characters
import random,os,time,socket
try: from subprocess import getoutput
except: from commands import getoutput
try: from cPickle import Pickler,Unpickler
except: from pickle import Pickler,Unpickler
try: from BaseHTTPServer import BaseHTTPRequestHandler, HTTPServer
except: from http.server import BaseHTTPRequestHandler, HTTPServer
try: import thread
except: import _thread as thread
def byPriority(a): return a.priority
priorityIfGotWrong = -10
priorityOfOtherCharWrong = -4
priorityOfGroupWrong = 0
maxShowInGroup = 5 ; priorityBreakGroup = 10
initSessionLen = sessionLen = 2 ; maxSessionLen = 10 ; sampleConst = 1.5
def updateSessionLen():
global sessionLen
sessionLen = min(max(sessionLen,int(thechars.countKnown()[1]+0.95)),maxSessionLen)
# did have /sampleConst after countKnown()[1] but doesn't seem necessary
already_spoken = {}
gradint_busy = 0
def speak_bkg():
gradint.just_synthesize()
global gradint_busy
gradint_busy = 0
class SingleChar:
def __init__(self,hanzi,pinyin):
self.hanzi = hanzi ; self.pinyin = pinyin
self.priority = 0 ; self.similarityGroup = None
self.supposedToKnow = 0
def formatPinyin(self): return self.pinyin.replace("\n","<BR>") # (could make it into actual tone marks also)
def htmlString(self,parent,step=1,left=0):
self.supposedToKnow = 1
r=u'<html><head><title>hanzi</title><meta http-equiv="Content-Type" content="text/html; charset=%s"></head><body><h1>%s</h1>' % (parent.charset,self.hanzi)
if step==1: r+=self.yesno('Do you know what this is? (%d remaining)' % left,2,0)
else:
r += self.formatPinyin() + "<HR>"
if step<=0:
if self.similarityGroup:
l = []
for c in parent.chars:
if c.similarityGroup == self.similarityGroup and not id(c)==id(self): l.append(c)
l.sort(key=byPriority)
r+="Not to be confused with:"
for c in l[:maxShowInGroup-1]: r+='<h1>%s</h1>%s' % (c.hanzi,c.formatPinyin())
r += '<hr>'
if parent.thisSession:
r+='<A HREF="/%s">Next character</A>' % str(random.random())
if step==-1:
# got it right - might as well take that link automatically
r=parent.processRequest("/").decode(parent.charset).replace('</body></html>','')
else:
updateSessionLen()
r+='<A HREF="/quit">Quit</A> | <A HREF="/%s">Another %d</A>' % (str(random.random()),sessionLen)
if step==0:
self.priority=priorityIfGotWrong
self.speak(parent.charset)
else:
# knew it
self.priority += 1
if self.priority > 0:
if self.priority < 25000: self.priority *= 2 # give new characters a chance
else: self.priority = 50000 # level off
else: self.priority /= 2 # TRY this for a while - will make chars got-wrong recover more quickly (again to give new chars a chance)
parent.save()
elif step==2:
r+=self.yesno('Did you get it right?',-1,3)
self.speak(parent.charset)
elif step==3:
r+='What did you think it was?<P>'
toOut = [] # (pinyin,hanzi,id,is-in-same-group)
for c in parent.chars:
if c.similarityGroup and c.similarityGroup==self.similarityGroup: sameGrp=True
else: sameGrp=False # need to do it this way because Python sometimes returns 'None' from that expression
if c.supposedToKnow and not id(c)==id(self): toOut.append((c.pinyin,c.hanzi,id(c),sameGrp)) # NOT formatPinyin, because may want to i-search it
toOut.sort()
if len(toOut) > 20: r+="(Hint: On some browsers you can use find-as-you-type)<P>"
for outSameGroup in [True,False]:
oldL=len(r)
for p,hanzi,val,sameGrp in toOut:
if sameGrp==outSameGroup: r+='%s <A HREF="/%d_%d">%s</A><BR>' % (hanzi,id(self),val,p)
if len(r)>oldL and outSameGroup: r += '<HR>' # between chars in same group and others
r+='<A HREF="/%d=0">None of the above</A>' % id(self)
if not parent.thisSession:
global already_spoken ; already_spoken = {} # reset it so "Another N" does speak them
return r + '</body></html>'
def speak(self,charset):
if self.hanzi in already_spoken: return
already_spoken[self.hanzi] = 1 # don't set a self. attribute - it'll get pickled for next session
if gradint:
gradint.justSynthesize = self.hanzi.decode(charset).encode('utf-8')
global gradint_busy
while gradint_busy: time.sleep(0.5)
gradint_busy = 1
thread.start_new_thread(speak_bkg,())
def yesno(self,question,ifyes,ifno): return question+'<P><A ID="y" HREF="/%d=%d">Yes</A><SCRIPT>document.getElementById("y").focus()</SCRIPT> | <A HREF="/%d=%d">No</A>' % (id(self),ifyes,id(self),ifno) # (don't use the js anywhere except yes/no, because 'next character' etc may have too much on the screen and we don't want the focus() to scroll)
the_speaker_process = None
def terminate_server():
# portable signal.alarm(1)
time.sleep(1); os.abort()
def B(s):
if type(u"")==type(""): return s.encode('utf-8')
else: return s
def S(s):
if type(u"")==type("") and not type(s)==type(""): return s.decode('utf-8')
else: return s
class CharDbase:
def __init__(self):
self.counter = 0 ; self.nextPriority = 0
self.similarityGroups = 0
self.chars = [] ; self.thisSession = []
self.readTable() ; self.readKnown() ; self.readRevise()
def debug_printKnown(self):
print ("-*- coding: %s -*-" % (self.charset,))
for c in self.chars:
if c.supposedToKnow: print ("%s %s" % (c.priority,c.hanzi))
def readTable(self):
addingTo = 0
if self.chars: addingTo = 1
lines=open(tableFile,'rb').readlines()
if lines[0].startswith(B("charset:")):
self.charset = S(lines[0].split()[-1])
lines = lines[1:]
else: self.charset = "iso-8859-1"
for line in lines: self.addCharFromFreqTable(line.decode(self.charset),addingTo)
def readKnown(self):
try:
o=open(knownFile)
except IOError: return
for line in o.readlines(): self.makeCharKnown(line.split()[0])
def readRevise(self):
try:
o=open(reviseFile)
except IOError: return
for line in o.readlines(): self.makeCharRevise(line.split()[0])
def makeCharKnown(self,hanzi):
if not hanzi: return # blank lines etc
for c in self.chars:
if c.hanzi==hanzi:
if not c.supposedToKnow:
c.supposedToKnow = 1
c.priority = priorityOfGroupWrong # just to check
return
print ("WARNING: character '%s' in %s was not in %s - ignoring" % (repr(hanzi),knownFile,tableFile))
def makeCharRevise(self,hanzi):
if not hanzi: return # blank lines etc
for c in self.chars:
if c.hanzi==hanzi:
c.supposedToKnow = 1
c.priority = priorityIfGotWrong
return
print ("WARNING: character '%s' in %s was not in %s - ignoring" % (repr(hanzi),reviseFile,tableFile))
def addCharFromFreqTable(self,line,checkAlreadyThere):
hanzi,pinyin = line.split(None,1)
c=SingleChar(hanzi,pinyin.replace("\\n","\n"))
c.priority = self.nextPriority ; self.nextPriority += 1
if checkAlreadyThere:
for c2 in self.chars:
if c2.hanzi == hanzi: return
self.chars.append(c)
def charIdToChar(self,charId):
char = None
for c in self.chars:
if id(c)==charId:
char = c ; break
assert char ; return char
def processRequest(self,path):
if '=' in path:
charId,step = map(lambda x:int(x),path[1:].split('='))
char = self.charIdToChar(charId)
elif '_' in path: # grouping
char,char2 = map(lambda x:self.charIdToChar(int(x)),path[1:].split('_'))
if not char.similarityGroup and not char2.similarityGroup: # new group:
self.similarityGroups += 1
char.similarityGroup = char2.similarityGroup = self.similarityGroups
elif not char.similarityGroup: char.similarityGroup = char2.similarityGroup
elif not char2.similarityGroup: char2.similarityGroup = char.similarityGroup
elif not char.similarityGroup == char2.similarityGroup: # merge 2 different groups:
for c in self.chars:
if c.similarityGroup == char2.similarityGroup: c.similarityGroup = char.similarityGroup
step = 0 # normal got-wrong for this character
char.priority = priorityIfGotWrong # here also, for the loop below
char2.priority = min(char2.priority,priorityOfOtherCharWrong)
for c in self.chars:
if c.similarityGroup == char.similarityGroup:
if c.priority >= priorityBreakGroup: c.similarityGroup=None
elif c.priority > priorityOfGroupWrong: c.priority = priorityOfGroupWrong
elif path=="/status":
self.chars.sort(key=byPriority)
cp=self.chars[:] ; r='<html><head><title>Current Status</title><meta http-equiv="Content-Type" content="text/html; charset=%s"></head><body><h2>Current Status</h2>(score/priority number is shown to the left of each item)<br>' % (self.charset,)
while cp:
if not cp[0].supposedToKnow:
del cp[0] ; continue
if cp[0].priority >= priorityBreakGroup: thisGrp=[0]
else: thisGrp=list(filter(lambda x:x==0 or (cp[x].similarityGroup and cp[x].similarityGroup==cp[0].similarityGroup and cp[x].priority < priorityBreakGroup),range(len(cp))))
if len(thisGrp)>1 and not r.endswith("<hr>"): r+="<hr>"
if len(thisGrp)>1: r+="<em>"+str(len(thisGrp))+" similar items:</em><br>"
for g in thisGrp: r += str(cp[g].priority)+": "+cp[g].hanzi+" "+cp[g].pinyin+"<br>"
if len(thisGrp)>1: r+="<hr>"
thisGrp.reverse()
for toDel in thisGrp: del cp[toDel]
return (r+"</body></html>").encode(self.charset)
else:
if path=="/checkallknown": self.thisSession = list(filter(lambda x:x.supposedToKnow,self.chars)) # TODO: Document this URL
char,step = self.chooseChar(),1
return char.htmlString(self,step,len(self.thisSession)).encode(self.charset)
def chooseChar(self):
if not self.thisSession:
self.chars.sort(key=byPriority)
if sessionLen==initSessionLen:
self.thisSession = self.chars[:sessionLen] # introduce in order the first time (especially if the second one is just a straight line ("yi1"), as one beginner thought the program had gone wrong when he saw this)
self.thisSession.reverse() # because taken out by pop()
else: self.thisSession = random.sample(self.chars[:int(sessionLen*sampleConst)],sessionLen) # TODO need a better way than that. NB high priority should be VERY likely, but others should have a chance. try as-is for now
return self.thisSession.pop()
def save(self): Pickler(open(dumpFile,"wb"),-1).dump(self)
def countKnown(self):
charsSeen = sessnLen = charsSecure = newChars = 0
secure=[] ; insecure=[]
self.chars.sort(key=byPriority)
for c in self.chars:
if c.supposedToKnow:
charsSeen += 1
if c.priority>0: secure.append(c.hanzi)
else: insecure.append(c.hanzi)
else: newChars += 1
if newChars == 2: sessnLen = charsSeen
return charsSeen,sessnLen,secure,insecure
try:
dumped = open(dumpFile,"rb")
except IOError: dumped = None
if dumped:
thechars = Unpickler(dumped).load()
dumped.close()
thechars.thisSession = []
if os.stat(tableFile).st_mtime > os.stat(dumpFile).st_mtime: thechars.readTable()
try:
if os.stat(knownFile).st_mtime > os.stat(dumpFile).st_mtime: thechars.readKnown()
except OSError: pass
try:
if os.stat(reviseFile).st_mtime > os.stat(dumpFile).st_mtime: thechars.readRevise()
except OSError: pass
updateSessionLen()
else:
thechars=CharDbase()
class RequestHandler(BaseHTTPRequestHandler):
def do_GET(self):
if self.path.startswith("/fav"):
self.send_response(404) ; self.end_headers() ; return
self.send_response(200)
self.send_header("Content-type","text/html; charset="+thechars.charset)
self.end_headers()
if self.path.startswith("/quit"):
r=thechars.processRequest("/status").decode(thechars.charset)
r=r[:r.index("<body>")+6]+"Server terminating."+r[r.index("<body>")+6:]
self.wfile.write(r.encode(thechars.charset))
thread.start_new_thread(terminate_server,()) # can terminate the server after this request
else: self.wfile.write(thechars.processRequest(self.path))
self.wfile.close() # needed or will wait for bkg speaking processes etc
def do_session():
portNo = firstPortNo ; server = None
while portNo < firstPortNo+100:
try:
server = HTTPServer((listenAddr,portNo),RequestHandler)
break
except socket.error: portNo += 1
assert server, "Couldn't find a port to run the server on"
if ("win" not in sys.platform) and getoutput("which x-www-browser 2>/dev/null"): # (try to find x-www-browser, but not on windows/cygwin/darwin)
os.system("x-www-browser http://localhost:%d/%s &" % (portNo,str(random.random()))) # shouldn't need a sleep as should take a while to start anyway
else:
try:
import webbrowser
webbrowser.open_new("http://localhost:%d/%s" % (portNo,str(random.random())))
except ImportError: pass # fall through to command-line message
# Do this as well, in case that command failed:
print ("") ; print ("") ; print ("")
print ("Server running. If a web browser does not appear automatically,")
print ("please start one yourself and go to")
print ("http://localhost:%d/%d" % (portNo,random.randint(1,99999)))
print ("") ; print ("") ; print ("")
server.serve_forever()
if sys.argv[-1]=='--count':
x,y,sec,insec=thechars.countKnown()
print ("%d (of which %d seem secure)" % (x,len(sec)))
elif sys.argv[-1]=='--show-secure':
x,y,sec,insec=thechars.countKnown()
print (" ".join(sec))
elif sys.argv[-1]=='--show-wfx':
# the result of this might need charset conversion
# (and the conversion of charlearn scores to Wenlin histories is only approximate)
print ("""<?xml version='1.0'?>
<!-- Wenlin Flashcard XML file -->
<stack owner='Anonymous' reward='points'>""")
thechars.chars.sort(key=byPriority)
for c in thechars.chars:
print ("<card type='d'><question>"+c.hanzi+"</question>")
trials = "" ; score = 0
if c.supposedToKnow:
if c.priority < 0:
trials += "n"
p = priorityIfGotWrong
while p < c.priority:
trials += "y" ; score += 1
p /= 2
p = 1
while p < c.priority:
trials += "y" ; score += 1
p *= 2
print ("<history score='%d' trials='%d' recent='%s'></history></card>" % (score,len(trials),trials))
print ("</stack>")
else: do_session()
charlearn/jp/characters.txt 0 → 100644
View file @ e16f7a7d
charset: euc-jp
あ a
い i
う u
え e
お o
か ka
き ki
く ku
け ke
こ ko
さ sa
し shi
す su
せ se
そ so
た ta
ち chi
つ tsu
て te
と to
な na
に ni
ぬ nu
ね ne
の no
は ha
ひ hi
ふ fu
へ he
ほ ho
ま ma
み mi
む mu
め me
も mo
や ya
ゆ yu
よ yo
ら ra
り ri
る ru
れ re
ろ ro
わ wa
を wo
ん n
ア a
イ i
ウ u
エ e
オ o
カ ka
キ ki
ク ku
ケ ke
コ ko
サ sa
シ shi
ス su
セ se
ソ so
タ ta
チ chi
ツ tsu
テ te
ト to
ナ na
ニ ni
ヌ nu
ネ ne
ノ no
ハ ha
ヒ hi
フ fu
ヘ he
ホ ho
マ ma
ミ mi
ム mu
メ me
モ mo
ヤ ya
ユ yu
ヨ yo
ラ ra
リ ri
ル ru
レ re
ロ ro
ワ wa
ヲ wo
ン n
gradint-build/INSTALL.txt deleted 100644 → 0
View file @ 14df51ec
Installing Gradint on Linux systems
-----------------------------------
Gradint does not need to be installed, it can
just run from the current directory.
If you do want to make a system-wide installation
(for example if you want to make a package for a
Linux distribution), I suggest doing the following
as root:
mkdir /usr/share/gradint
cp gradint.py /usr/share/gradint/
cd samples/utils
for F in *.py *.sh; do
export DestFile=/usr/bin/gradint-$(echo $F|sed -e 's/\..*//')
cp $F $DestFile
chmod +x $DestFile
done
cd ../.. ; rm -rf samples/utils
tar -zcf /usr/share/gradint/new-user.tgz \
advanced.txt settings.txt vocab.txt samples
cat > /usr/bin/gradint <<EOF
#!/bin/bash
if ! test -e "$HOME/gradint"; then
echo "You will need some prompts and samples in your home directory."
echo "Is it OK to unpack an example into $HOME/gradint ?"
echo "Ctrl-C to quit or Enter to continue"
read
echo -n "Unpacking... "
mkdir "$HOME/gradint"
cd "$HOME/gradint"
tar -zxf /usr/share/gradint/new-user.tgz
echo "done."
echo "Please check the contents of $HOME/gradint"
echo "especially the README files."
echo "Then you can run gradint again."
exit
fi
cd "$HOME/gradint"
python /usr/share/gradint/gradint.py $@
EOF
chmod +x /usr/bin/gradint
For a distribution you might also have to write
man pages and tidy up the help text etc.
Depends: python + a sound player (e.g. alsa-utils)
Recommends: python-tk python-tksnack sox libsox-fmt-all madplay
gradint-build/PocketPC/Program Files/lib/tcl8.4/auto.tcl deleted 100644 → 0
View file @ 14df51ec
# auto.tcl --
#
# utility procs formerly in init.tcl dealing with auto execution
# of commands and can be auto loaded themselves.
#
# RCS: @(#) $Id: auto.tcl,v 1.12 2002/10/28 16:34:25 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# auto_reset --
#
# Destroy all cached information for auto-loading and auto-execution,
# so that the information gets recomputed the next time it's needed.
# Also delete any procedures that are listed in the auto-load index
# except those defined in this file.
#
# Arguments:
# None.
proc auto_reset {} {
global auto_execs auto_index auto_oldpath
foreach p [info procs] {
if {[info exists auto_index($p)] && ![string match auto_* $p]
&& ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup
tcl_findLibrary pkg_compareExtension
tclPkgUnknown tcl::MacOSXPkgUnknown
tcl::MacPkgUnknown} $p] < 0)} {
rename $p {}
}
}
catch {unset auto_execs}
catch {unset auto_index}
catch {unset auto_oldpath}
}
# tcl_findLibrary --
#
# This is a utility for extensions that searches for a library directory
# using a canonical searching algorithm. A side effect is to source
# the initialization script and set a global library variable.
#
# Arguments:
# basename Prefix of the directory name, (e.g., "tk")
# version Version number of the package, (e.g., "8.0")
# patch Patchlevel of the package, (e.g., "8.0.3")
# initScript Initialization script to source (e.g., tk.tcl)
# enVarName environment variable to honor (e.g., TK_LIBRARY)
# varName Global variable to set when done (e.g., tk_library)
proc tcl_findLibrary {basename version patch initScript enVarName varName} {
upvar #0 $varName the_library
global env errorInfo
set dirs {}
set errors {}
# The C application may have hardwired a path, which we honor
set variableSet [info exists the_library]
if {$variableSet && [string compare $the_library {}]} {
lappend dirs $the_library
} else {
# Do the canonical search
# 1. From an environment variable, if it exists
if {[info exists env($enVarName)]} {
lappend dirs $env($enVarName)
}
# 2. Relative to the Tcl library
lappend dirs [file join [file dirname [info library]] \
$basename$version]
# 3. Various locations relative to the executable
# ../lib/foo1.0 (From bin directory in install hierarchy)
# ../../lib/foo1.0 (From bin/arch directory in install hierarchy)
# ../library (From unix directory in build hierarchy)
# ../../library (From unix/arch directory in build hierarchy)
# ../../foo1.0.1/library
# (From unix directory in parallel build hierarchy)
# ../../../foo1.0.1/library
# (From unix/arch directory in parallel build hierarchy)
set parentDir [file dirname [file dirname [info nameofexecutable]]]
set grandParentDir [file dirname $parentDir]
lappend dirs [file join $parentDir lib $basename$version]
lappend dirs [file join $grandParentDir lib $basename$version]
lappend dirs [file join $parentDir library]
lappend dirs [file join $grandParentDir library]
lappend dirs [file join $grandParentDir $basename$patch library]
lappend dirs [file join [file dirname $grandParentDir] \
$basename$patch library]
# 4. On MacOSX, check the directories in the tcl_pkgPath
if {[string equal $::tcl_platform(platform) "unix"] && \
[string equal $::tcl_platform(os) "Darwin"]} {
foreach d $::tcl_pkgPath {
lappend dirs [file join $d $basename$version]
lappend dirs [file join $d $basename$version Resources Scripts]
}
}
}
foreach i $dirs {
set the_library $i
set file [file join $i $initScript]
# source everything when in a safe interpreter because
# we have a source command, but no file exists command
if {[interp issafe] || [file exists $file]} {
if {![catch {uplevel #0 [list source $file]} msg]} {
return
} else {
append errors "$file: $msg\n$errorInfo\n"
}
}
}
if {!$variableSet} {
unset the_library
}
set msg "Can't find a usable $initScript in the following directories: \n"
append msg " $dirs\n\n"
append msg "$errors\n\n"
append msg "This probably means that $basename wasn't installed properly.\n"
error $msg
}
# ----------------------------------------------------------------------
# auto_mkindex
# ----------------------------------------------------------------------
# The following procedures are used to generate the tclIndex file
# from Tcl source files. They use a special safe interpreter to
# parse Tcl source files, writing out index entries as "proc"
# commands are encountered. This implementation won't work in a
# safe interpreter, since a safe interpreter can't create the
# special parser and mess with its commands.
if {[interp issafe]} {
return ;# Stop sourcing the file here
}
# auto_mkindex --
# Regenerate a tclIndex file from Tcl source files. Takes as argument
# the name of the directory in which the tclIndex file is to be placed,
# followed by any number of glob patterns to use in that directory to
# locate all of the relevant files.
#
# Arguments:
# dir - Name of the directory in which to create an index.
# args - Any number of additional arguments giving the
# names of files within dir. If no additional
# are given auto_mkindex will look for *.tcl.
proc auto_mkindex {dir args} {
global errorCode errorInfo
if {[interp issafe]} {
error "can't generate index within safe interpreter"
}
set oldDir [pwd]
cd $dir
set dir [pwd]
append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"auto_mkindex\" command\n"
append index "# and sourced to set up indexing information for one or\n"
append index "# more commands. Typically each line is a command that\n"
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
if {$args == ""} {
set args *.tcl
}
auto_mkindex_parser::init
foreach file [eval glob $args] {
if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} {
append index $msg
} else {
set code $errorCode
set info $errorInfo
cd $oldDir
error $msg $info $code
}
}
auto_mkindex_parser::cleanup
set fid [open "tclIndex" w]
puts -nonewline $fid $index
close $fid
cd $oldDir
}
# Original version of auto_mkindex that just searches the source
# code for "proc" at the beginning of the line.
proc auto_mkindex_old {dir args} {
global errorCode errorInfo
set oldDir [pwd]
cd $dir
set dir [pwd]
append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"auto_mkindex\" command\n"
append index "# and sourced to set up indexing information for one or\n"
append index "# more commands. Typically each line is a command that\n"
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
if {[string equal $args ""]} {
set args *.tcl
}
foreach file [eval glob $args] {
set f ""
set error [catch {
set f [open $file]
while {[gets $f line] >= 0} {
if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} {
set procName [lindex [auto_qualify $procName "::"] 0]
append index "set [list auto_index($procName)]"
append index " \[list source \[file join \$dir [list $file]\]\]\n"
}
}
close $f
} msg]
if {$error} {
set code $errorCode
set info $errorInfo
catch {close $f}
cd $oldDir
error $msg $info $code
}
}
set f ""
set error [catch {
set f [open tclIndex w]
puts -nonewline $f $index
close $f
cd $oldDir
} msg]
if {$error} {
set code $errorCode
set info $errorInfo
catch {close $f}
cd $oldDir
error $msg $info $code
}
}
# Create a safe interpreter that can be used to parse Tcl source files
# generate a tclIndex file for autoloading. This interp contains
# commands for things that need index entries. Each time a command
# is executed, it writes an entry out to the index file.
namespace eval auto_mkindex_parser {
variable parser "" ;# parser used to build index
variable index "" ;# maintains index as it is built
variable scriptFile "" ;# name of file being processed
variable contextStack "" ;# stack of namespace scopes
variable imports "" ;# keeps track of all imported cmds
variable initCommands "" ;# list of commands that create aliases
proc init {} {
variable parser
variable initCommands
if {![interp issafe]} {
set parser [interp create -safe]
$parser hide info
$parser hide rename
$parser hide proc
$parser hide namespace
$parser hide eval
$parser hide puts
$parser invokehidden namespace delete ::
$parser invokehidden proc unknown {args} {}
# We'll need access to the "namespace" command within the
# interp. Put it back, but move it out of the way.
$parser expose namespace
$parser invokehidden rename namespace _%@namespace
$parser expose eval
$parser invokehidden rename eval _%@eval
# Install all the registered psuedo-command implementations
foreach cmd $initCommands {
eval $cmd
}
}
}
proc cleanup {} {
variable parser
interp delete $parser
unset parser
}
}
# auto_mkindex_parser::mkindex --
#
# Used by the "auto_mkindex" command to create a "tclIndex" file for
# the given Tcl source file. Executes the commands in the file, and
# handles things like the "proc" command by adding an entry for the
# index file. Returns a string that represents the index file.
#
# Arguments:
# file Name of Tcl source file to be indexed.
proc auto_mkindex_parser::mkindex {file} {
variable parser
variable index
variable scriptFile
variable contextStack
variable imports
set scriptFile $file
set fid [open $file]
set contents [read $fid]
close $fid
# There is one problem with sourcing files into the safe
# interpreter: references like "$x" will fail since code is not
# really being executed and variables do not really exist.
# To avoid this, we replace all $ with \0 (literally, the null char)
# later, when getting proc names we will have to reverse this replacement,
# in case there were any $ in the proc name. This will cause a problem
# if somebody actually tries to have a \0 in their proc name. Too bad
# for them.
regsub -all {\$} $contents "\0" contents
set index ""
set contextStack ""
set imports ""
$parser eval $contents
foreach name $imports {
catch {$parser eval [list _%@namespace forget $name]}
}
return $index
}
# auto_mkindex_parser::hook command
#
# Registers a Tcl command to evaluate when initializing the
# slave interpreter used by the mkindex parser.
# The command is evaluated in the master interpreter, and can
# use the variable auto_mkindex_parser::parser to get to the slave
proc auto_mkindex_parser::hook {cmd} {
variable initCommands
lappend initCommands $cmd
}
# auto_mkindex_parser::slavehook command
#
# Registers a Tcl command to evaluate when initializing the
# slave interpreter used by the mkindex parser.
# The command is evaluated in the slave interpreter.
proc auto_mkindex_parser::slavehook {cmd} {
variable initCommands
# The $parser variable is defined to be the name of the
# slave interpreter when this command is used later.
lappend initCommands "\$parser eval [list $cmd]"
}
# auto_mkindex_parser::command --
#
# Registers a new command with the "auto_mkindex_parser" interpreter
# that parses Tcl files. These commands are fake versions of things
# like the "proc" command. When you execute them, they simply write
# out an entry to a "tclIndex" file for auto-loading.
#
# This procedure allows extensions to register their own commands
# with the auto_mkindex facility. For example, a package like
# [incr Tcl] might register a "class" command so that class definitions
# could be added to a "tclIndex" file for auto-loading.
#
# Arguments:
# name Name of command recognized in Tcl files.
# arglist Argument list for command.
# body Implementation of command to handle indexing.
proc auto_mkindex_parser::command {name arglist body} {
hook [list auto_mkindex_parser::commandInit $name $arglist $body]
}
# auto_mkindex_parser::commandInit --
#
# This does the actual work set up by auto_mkindex_parser::command
# This is called when the interpreter used by the parser is created.
#
# Arguments:
# name Name of command recognized in Tcl files.
# arglist Argument list for command.
# body Implementation of command to handle indexing.
proc auto_mkindex_parser::commandInit {name arglist body} {
variable parser
set ns [namespace qualifiers $name]
set tail [namespace tail $name]
if {[string equal $ns ""]} {
set fakeName "[namespace current]::_%@fake_$tail"
} else {
set fakeName "_%@fake_$name"
regsub -all {::} $fakeName "_" fakeName
set fakeName "[namespace current]::$fakeName"
}
proc $fakeName $arglist $body
# YUK! Tcl won't let us alias fully qualified command names,
# so we can't handle names like "::itcl::class". Instead,
# we have to build procs with the fully qualified names, and
# have the procs point to the aliases.
if {[regexp {::} $name]} {
set exportCmd [list _%@namespace export [namespace tail $name]]
$parser eval [list _%@namespace eval $ns $exportCmd]
# The following proc definition does not work if you
# want to tolerate space or something else diabolical
# in the procedure name, (i.e., space in $alias)
# The following does not work:
# "_%@eval {$alias} \$args"
# because $alias gets concat'ed to $args.
# The following does not work because $cmd is somehow undefined
# "set cmd {$alias} \; _%@eval {\$cmd} \$args"
# A gold star to someone that can make test
# autoMkindex-3.3 work properly
set alias [namespace tail $fakeName]
$parser invokehidden proc $name {args} "_%@eval {$alias} \$args"
$parser alias $alias $fakeName
} else {
$parser alias $name $fakeName
}
return
}
# auto_mkindex_parser::fullname --
# Used by commands like "proc" within the auto_mkindex parser.
# Returns the qualified namespace name for the "name" argument.
# If the "name" does not start with "::", elements are added from
# the current namespace stack to produce a qualified name. Then,
# the name is examined to see whether or not it should really be
# qualified. If the name has more than the leading "::", it is
# returned as a fully qualified name. Otherwise, it is returned
# as a simple name. That way, the Tcl autoloader will recognize
# it properly.
#
# Arguments:
# name - Name that is being added to index.
proc auto_mkindex_parser::fullname {name} {
variable contextStack
if {![string match ::* $name]} {
foreach ns $contextStack {
set name "${ns}::$name"
if {[string match ::* $name]} {
break
}
}
}
if {[string equal [namespace qualifiers $name] ""]} {
set name [namespace tail $name]
} elseif {![string match ::* $name]} {
set name "::$name"
}
# Earlier, mkindex replaced all $'s with \0. Now, we have to reverse
# that replacement.
regsub -all "\0" $name "\$" name
return $name
}
# Register all of the procedures for the auto_mkindex parser that
# will build the "tclIndex" file.
# AUTO MKINDEX: proc name arglist body
# Adds an entry to the auto index list for the given procedure name.
auto_mkindex_parser::command proc {name args} {
variable index
variable scriptFile
# Do some fancy reformatting on the "source" call to handle platform
# differences with respect to pathnames. Use format just so that the
# command is a little easier to read (otherwise it'd be full of
# backslashed dollar signs, etc.
append index [list set auto_index([fullname $name])] \
[format { [list source [file join $dir %s]]} \
[file split $scriptFile]] "\n"
}
# Conditionally add support for Tcl byte code files. There are some
# tricky details here. First, we need to get the tbcload library
# initialized in the current interpreter. We cannot load tbcload into the
# slave until we have done so because it needs access to the tcl_patchLevel
# variable. Second, because the package index file may defer loading the
# library until we invoke a command, we need to explicitly invoke auto_load
# to force it to be loaded. This should be a noop if the package has
# already been loaded
auto_mkindex_parser::hook {
if {![catch {package require tbcload}]} {
if {[llength [info commands tbcload::bcproc]] == 0} {
auto_load tbcload::bcproc
}
load {} tbcload $auto_mkindex_parser::parser
# AUTO MKINDEX: tbcload::bcproc name arglist body
# Adds an entry to the auto index list for the given pre-compiled
# procedure name.
auto_mkindex_parser::commandInit tbcload::bcproc {name args} {
variable index
variable scriptFile
# Do some nice reformatting of the "source" call, to get around
# path differences on different platforms. We use the format
# command just so that the code is a little easier to read.
append index [list set auto_index([fullname $name])] \
[format { [list source [file join $dir %s]]} \
[file split $scriptFile]] "\n"
}
}
}
# AUTO MKINDEX: namespace eval name command ?arg arg...?
# Adds the namespace name onto the context stack and evaluates the
# associated body of commands.
#
# AUTO MKINDEX: namespace import ?-force? pattern ?pattern...?
# Performs the "import" action in the parser interpreter. This is
# important for any commands contained in a namespace that affect
# the index. For example, a script may say "itcl::class ...",
# or it may import "itcl::*" and then say "class ...". This
# procedure does the import operation, but keeps track of imported
# patterns so we can remove the imports later.
auto_mkindex_parser::command namespace {op args} {
switch -- $op {
eval {
variable parser
variable contextStack
set name [lindex $args 0]
set args [lrange $args 1 end]
set contextStack [linsert $contextStack 0 $name]
$parser eval [list _%@namespace eval $name] $args
set contextStack [lrange $contextStack 1 end]
}
import {
variable parser
variable imports
foreach pattern $args {
if {[string compare $pattern "-force"]} {
lappend imports $pattern
}
}
catch {$parser eval "_%@namespace import $args"}
}
}
}
return
gradint-build/PocketPC/Program Files/lib/tcl8.4/history.tcl deleted 100644 → 0
View file @ 14df51ec
# history.tcl --
#
# Implementation of the history command.
#
# RCS: @(#) $Id: history.tcl,v 1.5 2001/05/17 08:18:56 hobbs Exp $
#
# Copyright (c) 1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# The tcl::history array holds the history list and
# some additional bookkeeping variables.
#
# nextid the index used for the next history list item.
# keep the max size of the history list
# oldest the index of the oldest item in the history.
namespace eval tcl {
variable history
if {![info exists history]} {
array set history {
nextid 0
keep 20
oldest -20
}
}
}
# history --
#
# This is the main history command. See the man page for its interface.
# This does argument checking and calls helper procedures in the
# history namespace.
proc history {args} {
set len [llength $args]
if {$len == 0} {
return [tcl::HistInfo]
}
set key [lindex $args 0]
set options "add, change, clear, event, info, keep, nextid, or redo"
switch -glob -- $key {
a* { # history add
if {$len > 3} {
return -code error "wrong # args: should be \"history add event ?exec?\""
}
if {![string match $key* add]} {
return -code error "bad option \"$key\": must be $options"
}
if {$len == 3} {
set arg [lindex $args 2]
if {! ([string match e* $arg] && [string match $arg* exec])} {
return -code error "bad argument \"$arg\": should be \"exec\""
}
}
return [tcl::HistAdd [lindex $args 1] [lindex $args 2]]
}
ch* { # history change
if {($len > 3) || ($len < 2)} {
return -code error "wrong # args: should be \"history change newValue ?event?\""
}
if {![string match $key* change]} {
return -code error "bad option \"$key\": must be $options"
}
if {$len == 2} {
set event 0
} else {
set event [lindex $args 2]
}
return [tcl::HistChange [lindex $args 1] $event]
}
cl* { # history clear
if {($len > 1)} {
return -code error "wrong # args: should be \"history clear\""
}
if {![string match $key* clear]} {
return -code error "bad option \"$key\": must be $options"
}
return [tcl::HistClear]
}
e* { # history event
if {$len > 2} {
return -code error "wrong # args: should be \"history event ?event?\""
}
if {![string match $key* event]} {
return -code error "bad option \"$key\": must be $options"
}
if {$len == 1} {
set event -1
} else {
set event [lindex $args 1]
}
return [tcl::HistEvent $event]
}
i* { # history info
if {$len > 2} {
return -code error "wrong # args: should be \"history info ?count?\""
}
if {![string match $key* info]} {
return -code error "bad option \"$key\": must be $options"
}
return [tcl::HistInfo [lindex $args 1]]
}
k* { # history keep
if {$len > 2} {
return -code error "wrong # args: should be \"history keep ?count?\""
}
if {$len == 1} {
return [tcl::HistKeep]
} else {
set limit [lindex $args 1]
if {[catch {expr {~$limit}}] || ($limit < 0)} {
return -code error "illegal keep count \"$limit\""
}
return [tcl::HistKeep $limit]
}
}
n* { # history nextid
if {$len > 1} {
return -code error "wrong # args: should be \"history nextid\""
}
if {![string match $key* nextid]} {
return -code error "bad option \"$key\": must be $options"
}
return [expr {$tcl::history(nextid) + 1}]
}
r* { # history redo
if {$len > 2} {
return -code error "wrong # args: should be \"history redo ?event?\""
}
if {![string match $key* redo]} {
return -code error "bad option \"$key\": must be $options"
}
return [tcl::HistRedo [lindex $args 1]]
}
default {
return -code error "bad option \"$key\": must be $options"
}
}
}
# tcl::HistAdd --
#
# Add an item to the history, and optionally eval it at the global scope
#
# Parameters:
# command the command to add
# exec (optional) a substring of "exec" causes the
# command to be evaled.
# Results:
# If executing, then the results of the command are returned
#
# Side Effects:
# Adds to the history list
proc tcl::HistAdd {command {exec {}}} {
variable history
# Do not add empty commands to the history
if {[string trim $command] == ""} {
return ""
}
set i [incr history(nextid)]
set history($i) $command
set j [incr history(oldest)]
if {[info exists history($j)]} {unset history($j)}
if {[string match e* $exec]} {
return [uplevel #0 $command]
} else {
return {}
}
}
# tcl::HistKeep --
#
# Set or query the limit on the length of the history list
#
# Parameters:
# limit (optional) the length of the history list
#
# Results:
# If no limit is specified, the current limit is returned
#
# Side Effects:
# Updates history(keep) if a limit is specified
proc tcl::HistKeep {{limit {}}} {
variable history
if {[string length $limit] == 0} {
return $history(keep)
} else {
set oldold $history(oldest)
set history(oldest) [expr {$history(nextid) - $limit}]
for {} {$oldold <= $history(oldest)} {incr oldold} {
if {[info exists history($oldold)]} {unset history($oldold)}
}
set history(keep) $limit
}
}
# tcl::HistClear --
#
# Erase the history list
#
# Parameters:
# none
#
# Results:
# none
#
# Side Effects:
# Resets the history array, except for the keep limit
proc tcl::HistClear {} {
variable history
set keep $history(keep)
unset history
array set history [list \
nextid 0 \
keep $keep \
oldest -$keep \
]
}
# tcl::HistInfo --
#
# Return a pretty-printed version of the history list
#
# Parameters:
# num (optional) the length of the history list to return
#
# Results:
# A formatted history list
proc tcl::HistInfo {{num {}}} {
variable history
if {$num == {}} {
set num [expr {$history(keep) + 1}]
}
set result {}
set newline ""
for {set i [expr {$history(nextid) - $num + 1}]} \
{$i <= $history(nextid)} {incr i} {
if {![info exists history($i)]} {
continue
}
set cmd [string trimright $history($i) \ \n]
regsub -all \n $cmd "\n\t" cmd
append result $newline[format "%6d %s" $i $cmd]
set newline \n
}
return $result
}
# tcl::HistRedo --
#
# Fetch the previous or specified event, execute it, and then
# replace the current history item with that event.
#
# Parameters:
# event (optional) index of history item to redo. Defaults to -1,
# which means the previous event.
#
# Results:
# Those of the command being redone.
#
# Side Effects:
# Replaces the current history list item with the one being redone.
proc tcl::HistRedo {{event -1}} {
variable history
if {[string length $event] == 0} {
set event -1
}
set i [HistIndex $event]
if {$i == $history(nextid)} {
return -code error "cannot redo the current event"
}
set cmd $history($i)
HistChange $cmd 0
uplevel #0 $cmd
}
# tcl::HistIndex --
#
# Map from an event specifier to an index in the history list.
#
# Parameters:
# event index of history item to redo.
# If this is a positive number, it is used directly.
# If it is a negative number, then it counts back to a previous
# event, where -1 is the most recent event.
# A string can be matched, either by being the prefix of
# a command or by matching a command with string match.
#
# Results:
# The index into history, or an error if the index didn't match.
proc tcl::HistIndex {event} {
variable history
if {[catch {expr {~$event}}]} {
for {set i [expr {$history(nextid)-1}]} {[info exists history($i)]} \
{incr i -1} {
if {[string match $event* $history($i)]} {
return $i;
}
if {[string match $event $history($i)]} {
return $i;
}
}
return -code error "no event matches \"$event\""
} elseif {$event <= 0} {
set i [expr {$history(nextid) + $event}]
} else {
set i $event
}
if {$i <= $history(oldest)} {
return -code error "event \"$event\" is too far in the past"
}
if {$i > $history(nextid)} {
return -code error "event \"$event\" hasn't occured yet"
}
return $i
}
# tcl::HistEvent --
#
# Map from an event specifier to the value in the history list.
#
# Parameters:
# event index of history item to redo. See index for a
# description of possible event patterns.
#
# Results:
# The value from the history list.
proc tcl::HistEvent {event} {
variable history
set i [HistIndex $event]
if {[info exists history($i)]} {
return [string trimright $history($i) \ \n]
} else {
return "";
}
}
# tcl::HistChange --
#
# Replace a value in the history list.
#
# Parameters:
# cmd The new value to put into the history list.
# event (optional) index of history item to redo. See index for a
# description of possible event patterns. This defaults
# to 0, which specifies the current event.
#
# Side Effects:
# Changes the history list.
proc tcl::HistChange {cmd {event 0}} {
variable history
set i [HistIndex $event]
set history($i) $cmd
}
gradint-build/PocketPC/Program Files/lib/tcl8.4/init.tcl deleted 100644 → 0
View file @ 14df51ec
# init.tcl --
#
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
# RCS: @(#) $Id: init.tcl,v 1.55 2002/11/23 01:41:35 hobbs Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
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.4
# 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.
# tclInitScript.h 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
# On Macintosh it is "Tool Command Language" in the Extensions folder
if {![info exists auto_path]} {
if {[info exists env(TCLLIBPATH)]} {
set auto_path $env(TCLLIBPATH)
} else {
set auto_path ""
}
}
namespace eval tcl {
variable Dir
if {[info library] != ""} {
foreach Dir [list [info library] [file dirname [info library]]] {
if {[lsearch -exact $::auto_path $Dir] < 0} {
lappend ::auto_path $Dir
}
}
}
set Dir [file join [file dirname [file dirname \
[info nameofexecutable]]] lib]
if {[lsearch -exact $::auto_path $Dir] < 0} {
lappend ::auto_path $Dir
}
if {[info exists ::tcl_pkgPath]} {
foreach Dir $::tcl_pkgPath {
if {[lsearch -exact $::auto_path $Dir] < 0} {
lappend ::auto_path $Dir
}
}
}
}
# Windows specific end of initialization
if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} {
namespace eval tcl {
proc EnvTraceProc {lo n1 n2 op} {
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 {![string equal $u $p]} {
switch -- $u {
COMSPEC -
PATH {
if {![info exists env($u)]} {
set env($u) $env($p)
}
trace variable env($p) w \
[namespace code [list EnvTraceProc $p]]
trace variable env($u) w \
[namespace code [list EnvTraceProc $p]]
}
}
}
}
if {![info exists env(COMSPEC)]} {
if {[string equal $tcl_platform(os) "Windows NT"]} {
set env(COMSPEC) cmd.exe
} else {
set env(COMSPEC) command.com
}
}
}
InitWinEnv
}
}
# Setup the unknown package handler
package unknown tclPkgUnknown
if {![interp issafe]} {
# setup platform specific unknown package handlers
if {[string equal $::tcl_platform(platform) "unix"] && \
[string equal $::tcl_platform(os) "Darwin"]} {
package unknown [list tcl::MacOSXPkgUnknown [package unknown]]
}
if {[string equal $::tcl_platform(platform) "macintosh"]} {
package unknown [list tcl::MacPkgUnknown [package unknown]]
}
}
# Conditionalize for presence of exec.
if {[llength [info commands exec]] == 0} {
# Some machines, such as the Macintosh, do not have exec. Also, on all
# platforms, safe interpreters do not have exec.
set auto_noexec 1
}
set errorCode ""
set errorInfo ""
# Define a log command (which can be overwitten to log errors
# differently, specially when stderr is not available)
if {[llength [info commands tclLog]] == 0} {
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 command has the form "namespace inscope ns cmd" and
# if so, concatenate its arguments onto the end and evaluate it.
# 2. See if the autoload facility can locate the command in a
# Tcl script file. If so, load it and execute it.
# 3. 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 {
global auto_noexec auto_noload env unknown_pending tcl_interactive
global errorCode errorInfo
# If the command word has the form "namespace inscope ns cmd"
# then concatenate its arguments onto the end and evaluate it.
set cmd [lindex $args 0]
if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
set arglist [lrange $args 1 end]
set ret [catch {uplevel 1 ::$cmd $arglist} result]
if {$ret == 0} {
return $result
} else {
return -code $ret -errorcode $errorCode $result
}
}
# Save the values of errorCode and errorInfo variables, since they
# may get modified if caught errors occur below. The variables will
# be restored just before re-executing the missing command.
set savedErrorCode $errorCode
set savedErrorInfo $errorInfo
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 unknown_pending($name)]} {
return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
}
set unknown_pending($name) pending;
set ret [catch {auto_load $name [uplevel 1 {::namespace current}]} msg]
unset unknown_pending($name);
if {$ret != 0} {
append errorInfo "\n (autoloading \"$name\")"
return -code $ret -errorcode $errorCode -errorinfo $errorInfo $msg
}
if {![array size unknown_pending]} {
unset unknown_pending
}
if {$msg} {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
set code [catch {uplevel 1 $args} msg]
if {$code == 1} {
#
# Compute stack trace contribution from the [uplevel].
# Note the dependence on how Tcl_AddErrorInfo, etc.
# construct the stack trace.
#
set cinfo $args
if {[string length $cinfo] > 150} {
set cinfo "[string range $cinfo 0 149]..."
}
append cinfo "\"\n (\"uplevel\" body line 1)"
append cinfo "\n invoked from within"
append cinfo "\n\"uplevel 1 \$args\""
#
# Try each possible form of the stack trace
# and trim the extra contribution from the matching case
#
set expect "$msg\n while executing\n\"$cinfo"
if {$errorInfo eq $expect} {
#
# The stack has only the eval from the expanded command
# Do not generate any stack trace here.
#
return -code error -errorcode $errorCode $msg
}
#
# Stack trace is nested, trim off just the contribution
# from the extra "eval" of $args due to the "catch" above.
#
set expect "\n invoked from within\n\"$cinfo"
set exlen [string length $expect]
set eilen [string length $errorInfo]
set i [expr {$eilen - $exlen - 1}]
set einfo [string range $errorInfo 0 $i]
#
# For now verify that $errorInfo consists of what we are about
# to return plus what we expected to trim off.
#
if {$errorInfo ne "$einfo$expect"} {
error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
[list CORE UNKNOWN BADTRACE $expect $errorInfo]
}
return -code error -errorcode $errorCode \
-errorinfo $einfo $msg
} else {
return -code $code $msg
}
}
}
if {([info level] == 1) && [string equal [info script] ""] \
&& [info exists tcl_interactive] && $tcl_interactive} {
if {![info exists auto_noexec]} {
set new [auto_execok $name]
if {$new != ""} {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
set redir ""
if {[string equal [info commands console] ""]} {
set redir ">&@stdout <@stdin"
}
return [uplevel 1 exec $redir $new [lrange $args 1 end]]
}
}
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
if {[string equal $name "!!"]} {
set newcmd [history event]
} elseif {[regexp {^!(.+)$} $name dummy event]} {
set newcmd [history event $event]
} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
set newcmd [history event -1]
catch {regsub -all -- $old $newcmd $new newcmd}
}
if {[info exists newcmd]} {
tclLog $newcmd
history change $newcmd 0
return [uplevel 1 $newcmd]
}
set ret [catch {set cmds [info commands $name*]} msg]
if {[string equal $name "::"]} {
set name ""
}
if {$ret != 0} {
return -code $ret -errorcode $errorCode \
"error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
}
if {[llength $cmds] == 1} {
return [uplevel 1 [lreplace $args 0 0 $cmds]]
}
if {[llength $cmds]} {
if {[string equal $name ""]} {
return -code error "empty command name \"\""
} else {
return -code error \
"ambiguous command name \"$name\": [lsort $cmds]"
}
}
}
return -code error "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_oldpath auto_path
if {[string length $namespace] == 0} {
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)]} {
uplevel #0 $auto_index($name)
return [expr {[info commands $name] != ""}]
}
}
if {![info exists auto_path]} {
return 0
}
if {![auto_load_index]} {
return 0
}
foreach name $nameList {
if {[info exists auto_index($name)]} {
uplevel #0 $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 { ![string equal [namespace which -command $name] ""] } {
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 {} {
global auto_index auto_oldpath auto_path errorInfo errorCode
if {[info exists auto_oldpath] && \
[string equal $auto_oldpath $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 {[string equal $id \
"# Tcl autoload index file, version 2.0"]} {
eval [read $f]
} elseif {[string equal $id "# Tcl autoload index file: each line identifies a Tcl"]} {
while {[gets $f line] >= 0} {
if {[string equal [string index $line 0] "#"] \
|| ([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]
if {$f != ""} {
close $f
}
if {$error} {
error $msg $errorInfo $errorCode
}
}
}
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 {[regexp {^::(.*)$} $cmd x tail]} {
if {$n > 1} {
# ( ::foo::bar , * ) -> ::foo::bar
return [list $cmd]
} else {
# ( ::global , * ) -> global
return [list $tail]
}
}
# Potentially returning 2 elements to try :
# (if the current namespace is not the global one)
if {$n == 0} {
if {[string equal $namespace ::]} {
# ( nocolons , :: ) -> nocolons
return [list $cmd]
} else {
# ( nocolons , ::sub ) -> ::sub::nocolons nocolons
return [list ${namespace}::$cmd $cmd]
}
} elseif {[string equal $namespace ::]} {
# ( 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 {[string equal "" [info commands $name]]
&& [string equal [namespace qualifiers $pattern] \
[namespace qualifiers $name]]} {
uplevel #0 $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 {[string equal windows $tcl_platform(platform)]} {
# Windows version.
#
# Note that info 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 cls copy date del erase dir echo mkdir \
md rename ren rmdir rd time type ver vol]
if {[string equal $tcl_platform(os) "Windows NT"]} {
# NT includes the 'start' built-in
lappend shellBuiltins "start"
}
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]
}
if {[lsearch -exact $shellBuiltins $name] != -1} {
# 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 {[string equal $tcl_platform(os) "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 dir [split $path {;}] {
# Skip already checked directories
if {[info exists checked($dir)] || [string equal {} $dir]} { continue }
set checked($dir) {}
foreach ext $execExtensions {
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 {[string equal $dir ""]} {
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 {[string equal $action "renaming"]} {
# Can't rename volumes. We could give a more precise
# error message here, but that would break the test suite.
if {[lsearch -exact [file volumes] $nsrc] != -1} {
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 == $ndest} {
return -code error "error $action \"$src\" to\
\"$dest\": trying to rename a volume or move a directory\
into itself"
}
if {[string equal $action "copying"]} {
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 * .*]
eval [list lappend existing] \
[glob -nocomplain -directory $dest -type hidden * .*]
foreach s $existing {
if {([file tail $s] != ".") && ([file tail $s] != "..")} {
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 == [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] != ".") && ([file tail $s] != "..")} {
file copy $s [file join $dest [file tail $s]]
}
}
return
}
gradint-build/PocketPC/Program Files/lib/tcl8.4/ldAout.tcl deleted 100644 → 0
View file @ 14df51ec
# ldAout.tcl --
#
# This "tclldAout" procedure in this script acts as a replacement
# for the "ld" command when linking an object file that will be
# loaded dynamically into Tcl or Tk using pseudo-static linking.
#
# Parameters:
# The arguments to the script are the command line options for
# an "ld" command.
#
# Results:
# The "ld" command is parsed, and the "-o" option determines the
# module name. ".a" and ".o" options are accumulated.
# The input archives and object files are examined with the "nm"
# command to determine whether the modules initialization
# entry and safe initialization entry are present. A trivial
# C function that locates the entries is composed, compiled, and
# its .o file placed before all others in the command; then
# "ld" is executed to bind the objects together.
#
# RCS: @(#) $Id: ldAout.tcl,v 1.5 2001/09/28 01:21:53 dgp Exp $
#
# Copyright (c) 1995, by General Electric Company. 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 work was supported in part by the ARPA Manufacturing Automation
# and Design Engineering (MADE) Initiative through ARPA contract
# F33615-94-C-4400.
proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
global env
global argv
if {[string equal $cc ""]} {
set cc $env(CC)
}
# if only two parameters are supplied there is assumed that the
# only shlib_suffix is missing. This parameter is anyway available
# as "info sharedlibextension" too, so there is no need to transfer
# 3 parameters to the function tclLdAout. For compatibility, this
# function now accepts both 2 and 3 parameters.
if {[string equal $shlib_suffix ""]} {
set shlib_cflags $env(SHLIB_CFLAGS)
} elseif {[string equal $shlib_cflags "none"]} {
set shlib_cflags $shlib_suffix
}
# seenDotO is nonzero if a .o or .a file has been seen
set seenDotO 0
# minusO is nonzero if the last command line argument was "-o".
set minusO 0
# head has command line arguments up to but not including the first
# .o or .a file. tail has the rest of the arguments.
set head {}
set tail {}
# nmCommand is the "nm" command that lists global symbols from the
# object files.
set nmCommand {|nm -g}
# entryProtos is the table of _Init and _SafeInit prototypes found in the
# module.
set entryProtos {}
# entryPoints is the table of _Init and _SafeInit entries found in the
# module.
set entryPoints {}
# libraries is the list of -L and -l flags to the linker.
set libraries {}
set libdirs {}
# Process command line arguments
foreach a $argv {
if {!$minusO && [regexp {\.[ao]$} $a]} {
set seenDotO 1
lappend nmCommand $a
}
if {$minusO} {
set outputFile $a
set minusO 0
} elseif {![string compare $a -o]} {
set minusO 1
}
if {[regexp {^-[lL]} $a]} {
lappend libraries $a
if {[regexp {^-L} $a]} {
lappend libdirs [string range $a 2 end]
}
} elseif {$seenDotO} {
lappend tail $a
} else {
lappend head $a
}
}
lappend libdirs /lib /usr/lib
# MIPS -- If there are corresponding G0 libraries, replace the
# ordinary ones with the G0 ones.
set libs {}
foreach lib $libraries {
if {[regexp {^-l} $lib]} {
set lname [string range $lib 2 end]
foreach dir $libdirs {
if {[file exists [file join $dir lib${lname}_G0.a]]} {
set lname ${lname}_G0
break
}
}
lappend libs -l$lname
} else {
lappend libs $lib
}
}
set libraries $libs
# Extract the module name from the "-o" option
if {![info exists outputFile]} {
error "-o option must be supplied to link a Tcl load module"
}
set m [file tail $outputFile]
if {[regexp {\.a$} $outputFile]} {
set shlib_suffix .a
} else {
set shlib_suffix ""
}
if {[regexp {\..*$} $outputFile match]} {
set l [expr {[string length $m] - [string length $match]}]
} else {
error "Output file does not appear to have a suffix"
}
set modName [string tolower $m 0 [expr {$l-1}]]
if {[regexp {^lib} $modName]} {
set modName [string range $modName 3 end]
}
if {[regexp {[0-9\.]*(_g0)?$} $modName match]} {
set modName [string range $modName 0 [expr {[string length $modName]-[string length $match]-1}]]
}
set modName [string totitle $modName]
# Catalog initialization entry points found in the module
set f [open $nmCommand r]
while {[gets $f l] >= 0} {
if {[regexp {T[ ]*_?([A-Z][a-z0-9_]*_(Safe)?Init(__FP10Tcl_Interp)?)$} $l trash symbol]} {
if {![regexp {_?([A-Z][a-z0-9_]*_(Safe)?Init)} $symbol trash s]} {
set s $symbol
}
append entryProtos {extern int } $symbol { (); } \n
append entryPoints { } \{ { "} $s {", } $symbol { } \} , \n
}
}
close $f
if {[string equal $entryPoints ""]} {
error "No entry point found in objects"
}
# Compose a C function that resolves the initialization entry points and
# embeds the required libraries in the object code.
set C {#include <string.h>}
append C \n
append C {char TclLoadLibraries_} $modName { [] =} \n
append C { "@LIBS: } $libraries {";} \n
append C $entryProtos
append C {static struct } \{ \n
append C { char * name;} \n
append C { int (*value)();} \n
append C \} {dictionary [] = } \{ \n
append C $entryPoints
append C { 0, 0 } \n \} \; \n
append C {typedef struct Tcl_Interp Tcl_Interp;} \n
append C {typedef int Tcl_PackageInitProc (Tcl_Interp *);} \n
append C {Tcl_PackageInitProc *} \n
append C TclLoadDictionary_ $modName { (symbol)} \n
append C { CONST char * symbol;} \n
append C {
{
int i;
for (i = 0; dictionary [i] . name != 0; ++i) {
if (!strcmp (symbol, dictionary [i] . name)) {
return dictionary [i].value;
}
}
return 0;
}
}
append C \n
# Write the C module and compile it
set cFile tcl$modName.c
set f [open $cFile w]
puts -nonewline $f $C
close $f
set ccCommand "$cc -c $shlib_cflags $cFile"
puts stderr $ccCommand
eval exec $ccCommand
# Now compose and execute the ld command that packages the module
if {[string equal $shlib_suffix ".a"]} {
set ldCommand "ar cr $outputFile"
regsub { -o} $tail {} tail
} else {
set ldCommand ld
foreach item $head {
lappend ldCommand $item
}
}
lappend ldCommand tcl$modName.o
foreach item $tail {
lappend ldCommand $item
}
puts stderr $ldCommand
eval exec $ldCommand
if {[string equal $shlib_suffix ".a"]} {
exec ranlib $outputFile
}
# Clean up working files
exec /bin/rm $cFile [file rootname $cFile].o
}
gradint-build/PocketPC/Program Files/lib/tcl8.4/package.tcl deleted 100644 → 0
View file @ 14df51ec
# package.tcl --
#
# utility procs formerly in init.tcl which can be loaded on demand
# for package management.
#
# RCS: @(#) $Id: package.tcl,v 1.23 2003/02/25 23:58:09 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Create the package namespace
namespace eval ::pkg {
}
# pkg_compareExtension --
#
# Used internally by pkg_mkIndex to compare the extension of a file to
# a given extension. On Windows, it uses a case-insensitive comparison
# because the file system can be file insensitive.
#
# Arguments:
# fileName name of a file whose extension is compared
# ext (optional) The extension to compare against; you must
# provide the starting dot.
# Defaults to [info sharedlibextension]
#
# Results:
# Returns 1 if the extension matches, 0 otherwise
proc pkg_compareExtension { fileName {ext {}} } {
global tcl_platform
if {![string length $ext]} {set ext [info sharedlibextension]}
if {[string equal $tcl_platform(platform) "windows"]} {
return [string equal -nocase [file extension $fileName] $ext]
} else {
# Some unices add trailing numbers after the .so, so
# we could have something like '.so.1.2'.
set root $fileName
while {1} {
set currExt [file extension $root]
if {[string equal $currExt $ext]} {
return 1
}
# The current extension does not match; if it is not a numeric
# value, quit, as we are only looking to ignore version number
# extensions. Otherwise we might return 1 in this case:
# pkg_compareExtension foo.so.bar .so
# which should not match.
if { ![string is integer -strict [string range $currExt 1 end]] } {
return 0
}
set root [file rootname $root]
}
}
}
# pkg_mkIndex --
# This procedure creates a package index in a given directory. The
# package index consists of a "pkgIndex.tcl" file whose contents are
# a Tcl script that sets up package information with "package require"
# commands. The commands describe all of the packages defined by the
# files given as arguments.
#
# Arguments:
# -direct (optional) If this flag is present, the generated
# code in pkgMkIndex.tcl will cause the package to be
# loaded when "package require" is executed, rather
# than lazily when the first reference to an exported
# procedure in the package is made.
# -verbose (optional) Verbose output; the name of each file that
# was successfully rocessed is printed out. Additionally,
# if processing of a file failed a message is printed.
# -load pat (optional) Preload any packages whose names match
# the pattern. Used to handle DLLs that depend on
# other packages during their Init procedure.
# dir - Name of the directory in which to create the index.
# args - Any number of additional arguments, each giving
# a glob pattern that matches the names of one or
# more shared libraries or Tcl script files in
# dir.
proc pkg_mkIndex {args} {
global errorCode errorInfo
set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"};
set argCount [llength $args]
if {$argCount < 1} {
return -code error "wrong # args: should be\n$usage"
}
set more ""
set direct 1
set doVerbose 0
set loadPat ""
for {set idx 0} {$idx < $argCount} {incr idx} {
set flag [lindex $args $idx]
switch -glob -- $flag {
-- {
# done with the flags
incr idx
break
}
-verbose {
set doVerbose 1
}
-lazy {
set direct 0
append more " -lazy"
}
-direct {
append more " -direct"
}
-load {
incr idx
set loadPat [lindex $args $idx]
append more " -load $loadPat"
}
-* {
return -code error "unknown flag $flag: should be\n$usage"
}
default {
# done with the flags
break
}
}
}
set dir [lindex $args $idx]
set patternList [lrange $args [expr {$idx + 1}] end]
if {[llength $patternList] == 0} {
set patternList [list "*.tcl" "*[info sharedlibextension]"]
}
set oldDir [pwd]
cd $dir
if {[catch {eval glob $patternList} fileList]} {
global errorCode errorInfo
cd $oldDir
return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList
}
foreach file $fileList {
# For each file, figure out what commands and packages it provides.
# To do this, create a child interpreter, load the file into the
# interpreter, and get a list of the new commands and packages
# that are defined.
if {[string equal $file "pkgIndex.tcl"]} {
continue
}
# Changed back to the original directory before initializing the
# slave in case TCL_LIBRARY is a relative path (e.g. in the test
# suite).
cd $oldDir
set c [interp create]
# Load into the child any packages currently loaded in the parent
# interpreter that match the -load pattern.
if {[string length $loadPat]} {
if {$doVerbose} {
tclLog "currently loaded packages: '[info loaded]'"
tclLog "trying to load all packages matching $loadPat"
}
if {![llength [info loaded]]} {
tclLog "warning: no packages are currently loaded, nothing"
tclLog "can possibly match '$loadPat'"
}
}
foreach pkg [info loaded] {
if {! [string match -nocase $loadPat [lindex $pkg 1]]} {
continue
}
if {$doVerbose} {
tclLog "package [lindex $pkg 1] matches '$loadPat'"
}
if {[catch {
load [lindex $pkg 0] [lindex $pkg 1] $c
} err]} {
if {$doVerbose} {
tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
}
} elseif {$doVerbose} {
tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
}
if {[string equal [lindex $pkg 1] "Tk"]} {
# Withdraw . if Tk was loaded, to avoid showing a window.
$c eval [list wm withdraw .]
}
}
cd $dir
$c eval {
# Stub out the package command so packages can
# require other packages.
rename package __package_orig
proc package {what args} {
switch -- $what {
require { return ; # ignore transitive requires }
default { eval __package_orig {$what} $args }
}
}
proc tclPkgUnknown args {}
package unknown tclPkgUnknown
# Stub out the unknown command so package can call
# into each other during their initialilzation.
proc unknown {args} {}
# Stub out the auto_import mechanism
proc auto_import {args} {}
# reserve the ::tcl namespace for support procs
# and temporary variables. This might make it awkward
# to generate a pkgIndex.tcl file for the ::tcl namespace.
namespace eval ::tcl {
variable file ;# Current file being processed
variable direct ;# -direct flag value
variable x ;# Loop variable
variable debug ;# For debugging
variable type ;# "load" or "source", for -direct
variable namespaces ;# Existing namespaces (e.g., ::tcl)
variable packages ;# Existing packages (e.g., Tcl)
variable origCmds ;# Existing commands
variable newCmds ;# Newly created commands
variable newPkgs {} ;# Newly created packages
}
}
$c eval [list set ::tcl::file $file]
$c eval [list set ::tcl::direct $direct]
# Download needed procedures into the slave because we've
# just deleted the unknown procedure. This doesn't handle
# procedures with default arguments.
foreach p {pkg_compareExtension} {
$c eval [list proc $p [info args $p] [info body $p]]
}
if {[catch {
$c eval {
set ::tcl::debug "loading or sourcing"
# we need to track command defined by each package even in
# the -direct case, because they are needed internally by
# the "partial pkgIndex.tcl" step above.
proc ::tcl::GetAllNamespaces {{root ::}} {
set list $root
foreach ns [namespace children $root] {
eval lappend list [::tcl::GetAllNamespaces $ns]
}
return $list
}
# init the list of existing namespaces, packages, commands
foreach ::tcl::x [::tcl::GetAllNamespaces] {
set ::tcl::namespaces($::tcl::x) 1
}
foreach ::tcl::x [package names] {
set ::tcl::packages($::tcl::x) 1
}
set ::tcl::origCmds [info commands]
# Try to load the file if it has the shared library
# extension, otherwise source it. It's important not to
# try to load files that aren't shared libraries, because
# on some systems (like SunOS) the loader will abort the
# whole application when it gets an error.
if {[pkg_compareExtension $::tcl::file [info sharedlibextension]]} {
# The "file join ." command below is necessary.
# Without it, if the file name has no \'s and we're
# on UNIX, the load command will invoke the
# LD_LIBRARY_PATH search mechanism, which could cause
# the wrong file to be used.
set ::tcl::debug loading
load [file join . $::tcl::file]
set ::tcl::type load
} else {
set ::tcl::debug sourcing
source $::tcl::file
set ::tcl::type source
}
# As a performance optimization, if we are creating
# direct load packages, don't bother figuring out the
# set of commands created by the new packages. We
# only need that list for setting up the autoloading
# used in the non-direct case.
if { !$::tcl::direct } {
# See what new namespaces appeared, and import commands
# from them. Only exported commands go into the index.
foreach ::tcl::x [::tcl::GetAllNamespaces] {
if {! [info exists ::tcl::namespaces($::tcl::x)]} {
namespace import -force ${::tcl::x}::*
}
# Figure out what commands appeared
foreach ::tcl::x [info commands] {
set ::tcl::newCmds($::tcl::x) 1
}
foreach ::tcl::x $::tcl::origCmds {
catch {unset ::tcl::newCmds($::tcl::x)}
}
foreach ::tcl::x [array names ::tcl::newCmds] {
# determine which namespace a command comes from
set ::tcl::abs [namespace origin $::tcl::x]
# special case so that global names have no leading
# ::, this is required by the unknown command
set ::tcl::abs \
[lindex [auto_qualify $::tcl::abs ::] 0]
if {[string compare $::tcl::x $::tcl::abs]} {
# Name changed during qualification
set ::tcl::newCmds($::tcl::abs) 1
unset ::tcl::newCmds($::tcl::x)
}
}
}
}
# Look through the packages that appeared, and if there is
# a version provided, then record it
foreach ::tcl::x [package names] {
if {[string compare [package provide $::tcl::x] ""] \
&& ![info exists ::tcl::packages($::tcl::x)]} {
lappend ::tcl::newPkgs \
[list $::tcl::x [package provide $::tcl::x]]
}
}
}
} msg] == 1} {
set what [$c eval set ::tcl::debug]
if {$doVerbose} {
tclLog "warning: error while $what $file: $msg"
}
} else {
set what [$c eval set ::tcl::debug]
if {$doVerbose} {
tclLog "successful $what of $file"
}
set type [$c eval set ::tcl::type]
set cmds [lsort [$c eval array names ::tcl::newCmds]]
set pkgs [$c eval set ::tcl::newPkgs]
if {$doVerbose} {
tclLog "commands provided were $cmds"
tclLog "packages provided were $pkgs"
}
if {[llength $pkgs] > 1} {
tclLog "warning: \"$file\" provides more than one package ($pkgs)"
}
foreach pkg $pkgs {
# cmds is empty/not used in the direct case
lappend files($pkg) [list $file $type $cmds]
}
if {$doVerbose} {
tclLog "processed $file"
}
}
interp delete $c
}
append index "# Tcl package index file, version 1.1\n"
append index "# This file is generated by the \"pkg_mkIndex$more\" command\n"
append index "# and sourced either when an application starts up or\n"
append index "# by a \"package unknown\" script. It invokes the\n"
append index "# \"package ifneeded\" command to set up package-related\n"
append index "# information so that packages will be loaded automatically\n"
append index "# in response to \"package require\" commands. When this\n"
append index "# script is sourced, the variable \$dir must contain the\n"
append index "# full path name of this file's directory.\n"
foreach pkg [lsort [array names files]] {
set cmd {}
foreach {name version} $pkg {
break
}
lappend cmd ::pkg::create -name $name -version $version
foreach spec $files($pkg) {
foreach {file type procs} $spec {
if { $direct } {
set procs {}
}
lappend cmd "-$type" [list $file $procs]
}
}
append index "\n[eval $cmd]"
}
set f [open pkgIndex.tcl w]
puts $f $index
close $f
cd $oldDir
}
# tclPkgSetup --
# This is a utility procedure use by pkgIndex.tcl files. It is invoked
# as part of a "package ifneeded" script. It calls "package provide"
# to indicate that a package is available, then sets entries in the
# auto_index array so that the package's files will be auto-loaded when
# the commands are used.
#
# Arguments:
# dir - Directory containing all the files for this package.
# pkg - Name of the package (no version number).
# version - Version number for the package, such as 2.1.3.
# files - List of files that constitute the package. Each
# element is a sub-list with three elements. The first
# is the name of a file relative to $dir, the second is
# "load" or "source", indicating whether the file is a
# loadable binary or a script to source, and the third
# is a list of commands defined by this file.
proc tclPkgSetup {dir pkg version files} {
global auto_index
package provide $pkg $version
foreach fileInfo $files {
set f [lindex $fileInfo 0]
set type [lindex $fileInfo 1]
foreach cmd [lindex $fileInfo 2] {
if {[string equal $type "load"]} {
set auto_index($cmd) [list load [file join $dir $f] $pkg]
} else {
set auto_index($cmd) [list source [file join $dir $f]]
}
}
}
}
# tclPkgUnknown --
# This procedure provides the default for the "package unknown" function.
# It is invoked when a package that's needed can't be found. It scans
# the auto_path directories and their immediate children looking for
# pkgIndex.tcl files and sources any such files that are found to setup
# the package database. (On the Macintosh we also search for pkgIndex
# TEXT resources in all files.) As it searches, it will recognize changes
# to the auto_path and scan any new directories.
#
# Arguments:
# name - Name of desired package. Not used.
# version - Version of desired package. Not used.
# exact - Either "-exact" or omitted. Not used.
proc tclPkgUnknown {name version {exact {}}} {
global auto_path env
if {![info exists auto_path]} {
return
}
# Cache the auto_path, because it may change while we run through
# the first set of pkgIndex.tcl files
set old_path [set use_path $auto_path]
while {[llength $use_path]} {
set dir [lindex $use_path end]
# Make sure we only scan each directory one time.
if {[info exists tclSeenPath($dir)]} {
set use_path [lrange $use_path 0 end-1]
continue
}
set tclSeenPath($dir) 1
# we can't use glob in safe interps, so enclose the following
# in a catch statement, where we get the pkgIndex files out
# of the subdirectories
catch {
foreach file [glob -directory $dir -join -nocomplain \
* pkgIndex.tcl] {
set dir [file dirname $file]
if {![info exists procdDirs($dir)] && [file readable $file]} {
if {[catch {source $file} msg]} {
tclLog "error reading package index file $file: $msg"
} else {
set procdDirs($dir) 1
}
}
}
}
set dir [lindex $use_path end]
if {![info exists procdDirs($dir)]} {
set file [file join $dir pkgIndex.tcl]
# safe interps usually don't have "file readable",
# nor stderr channel
if {([interp issafe] || [file readable $file])} {
if {[catch {source $file} msg] && ![interp issafe]} {
tclLog "error reading package index file $file: $msg"
} else {
set procdDirs($dir) 1
}
}
}
set use_path [lrange $use_path 0 end-1]
# Check whether any of the index scripts we [source]d above
# set a new value for $::auto_path. If so, then find any
# new directories on the $::auto_path, and lappend them to
# the $use_path we are working from. This gives index scripts
# the (arguably unwise) power to expand the index script search
# path while the search is in progress.
set index 0
if {[llength $old_path] == [llength $auto_path]} {
foreach dir $auto_path old $old_path {
if {$dir ne $old} {
# This entry in $::auto_path has changed.
break
}
incr index
}
}
# $index now points to the first element of $auto_path that
# has changed, or the beginning if $auto_path has changed length
# Scan the new elements of $auto_path for directories to add to
# $use_path. Don't add directories we've already seen, or ones
# already on the $use_path.
foreach dir [lrange $auto_path $index end] {
if {![info exists tclSeenPath($dir)]
&& ([lsearch -exact $use_path $dir] == -1) } {
lappend use_path $dir
}
}
set old_path $auto_path
}
}
# tcl::MacOSXPkgUnknown --
# This procedure extends the "package unknown" function for MacOSX.
# It scans the Resources/Scripts directories of the immediate children
# of the auto_path directories for pkgIndex files.
# Only installed in interps that are not safe so we don't check
# for [interp issafe] as in tclPkgUnknown.
#
# Arguments:
# original - original [package unknown] procedure
# name - Name of desired package. Not used.
# version - Version of desired package. Not used.
# exact - Either "-exact" or omitted. Not used.
proc tcl::MacOSXPkgUnknown {original name version {exact {}}} {
# First do the cross-platform default search
uplevel 1 $original [list $name $version $exact]
# Now do MacOSX specific searching
global auto_path
if {![info exists auto_path]} {
return
}
# Cache the auto_path, because it may change while we run through
# the first set of pkgIndex.tcl files
set old_path [set use_path $auto_path]
while {[llength $use_path]} {
set dir [lindex $use_path end]
# get the pkgIndex files out of the subdirectories
foreach file [glob -directory $dir -join -nocomplain \
* Resources Scripts pkgIndex.tcl] {
set dir [file dirname $file]
if {[file readable $file] && ![info exists procdDirs($dir)]} {
if {[catch {source $file} msg]} {
tclLog "error reading package index file $file: $msg"
} else {
set procdDirs($dir) 1
}
}
}
set use_path [lrange $use_path 0 end-1]
if {[string compare $old_path $auto_path]} {
foreach dir $auto_path {
lappend use_path $dir
}
set old_path $auto_path
}
}
}
# tcl::MacPkgUnknown --
# This procedure extends the "package unknown" function for Mac.
# It searches for pkgIndex TEXT resources in all files
# Only installed in interps that are not safe so we don't check
# for [interp issafe] as in tclPkgUnknown.
#
# Arguments:
# original - original [package unknown] procedure
# name - Name of desired package. Not used.
# version - Version of desired package. Not used.
# exact - Either "-exact" or omitted. Not used.
proc tcl::MacPkgUnknown {original name version {exact {}}} {
# First do the cross-platform default search
uplevel 1 $original [list $name $version $exact]
# Now do Mac specific searching
global auto_path
if {![info exists auto_path]} {
return
}
# Cache the auto_path, because it may change while we run through
# the first set of pkgIndex.tcl files
set old_path [set use_path $auto_path]
while {[llength $use_path]} {
# We look for pkgIndex TEXT resources in the resource fork of shared libraries
set dir [lindex $use_path end]
foreach x [concat [list $dir] [glob -directory $dir -nocomplain *] ] {
if {[file isdirectory $x] && ![info exists procdDirs($x)]} {
set dir $x
foreach x [glob -directory $dir -nocomplain *.shlb] {
if {[file isfile $x]} {
set res [resource open $x]
foreach y [resource list TEXT $res] {
if {[string equal $y "pkgIndex"]} {source -rsrc pkgIndex}
}
catch {resource close $res}
}
}
set procdDirs($dir) 1
}
}
set use_path [lrange $use_path 0 end-1]
if {[string compare $old_path $auto_path]} {
foreach dir $auto_path {
lappend use_path $dir
}
set old_path $auto_path
}
}
}
# ::pkg::create --
#
# Given a package specification generate a "package ifneeded" statement
# for the package, suitable for inclusion in a pkgIndex.tcl file.
#
# Arguments:
# args arguments used by the create function:
# -name packageName
# -version packageVersion
# -load {filename ?{procs}?}
# ...
# -source {filename ?{procs}?}
# ...
#
# Any number of -load and -source parameters may be
# specified, so long as there is at least one -load or
# -source parameter. If the procs component of a
# module specifier is left off, that module will be
# set up for direct loading; otherwise, it will be
# set up for lazy loading. If both -source and -load
# are specified, the -load'ed files will be loaded
# first, followed by the -source'd files.
#
# Results:
# An appropriate "package ifneeded" statement for the package.
proc ::pkg::create {args} {
append err(usage) "[lindex [info level 0] 0] "
append err(usage) "-name packageName -version packageVersion"
append err(usage) "?-load {filename ?{procs}?}? ... "
append err(usage) "?-source {filename ?{procs}?}? ..."
set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\""
set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\""
set err(unknownOpt) "unknown option \"%s\": should be \"$err(usage)\""
set err(noLoadOrSource) "at least one of -load and -source must be given"
# process arguments
set len [llength $args]
if { $len < 6 } {
error $err(wrongNumArgs)
}
# Initialize parameters
set opts(-name) {}
set opts(-version) {}
set opts(-source) {}
set opts(-load) {}
# process parameters
for {set i 0} {$i < $len} {incr i} {
set flag [lindex $args $i]
incr i
switch -glob -- $flag {
"-name" -
"-version" {
if { $i >= $len } {
error [format $err(valueMissing) $flag]
}
set opts($flag) [lindex $args $i]
}
"-source" -
"-load" {
if { $i >= $len } {
error [format $err(valueMissing) $flag]
}
lappend opts($flag) [lindex $args $i]
}
default {
error [format $err(unknownOpt) [lindex $args $i]]
}
}
}
# Validate the parameters
if { [llength $opts(-name)] == 0 } {
error [format $err(valueMissing) "-name"]
}
if { [llength $opts(-version)] == 0 } {
error [format $err(valueMissing) "-version"]
}
if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } {
error $err(noLoadOrSource)
}
# OK, now everything is good. Generate the package ifneeded statment.
set cmdline "package ifneeded $opts(-name) $opts(-version) "
set cmdList {}
set lazyFileList {}
# Handle -load and -source specs
foreach key {load source} {
foreach filespec $opts(-$key) {
foreach {filename proclist} {{} {}} {
break
}
foreach {filename proclist} $filespec {
break
}
if { [llength $proclist] == 0 } {
set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
lappend cmdList $cmd
} else {
lappend lazyFileList [list $filename $key $proclist]
}
}
}
if { [llength $lazyFileList] > 0 } {
lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\
$opts(-version) [list $lazyFileList]\]"
}
append cmdline [join $cmdList "\\n"]
return $cmdline
}
gradint-build/PocketPC/Program Files/lib/tcl8.4/parray.tcl deleted 100644 → 0
View file @ 14df51ec
# parray:
# Print the contents of a global array on stdout.
#
# RCS: @(#) $Id: parray.tcl,v 1.3 1998/09/14 18:40:03 stanton Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
proc parray {a {pattern *}} {
upvar 1 $a array
if {![array exists array]} {
error "\"$a\" isn't an array"
}
set maxl 0
foreach name [lsort [array names array $pattern]] {
if {[string length $name] > $maxl} {
set maxl [string length $name]
}
}
set maxl [expr {$maxl + [string length $a] + 2}]
foreach name [lsort [array names array $pattern]] {
set nameString [format %s(%s) $a $name]
puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
}
}
gradint-build/PocketPC/Program Files/lib/tcl8.4/safe.tcl deleted 100644 → 0
View file @ 14df51ec
# safe.tcl --
#
# This file provide a safe loading/sourcing mechanism for safe interpreters.
# It implements a virtual path mecanism to hide the real pathnames from the
# slave. It runs in a master interpreter and sets up data structure and
# aliases that will be invoked when used from a slave interpreter.
#
# See the safe.n man page for details.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: safe.tcl,v 1.9 2003/02/08 22:03:20 hobbs Exp $
#
# The implementation is based on namespaces. These naming conventions
# are followed:
# Private procs starts with uppercase.
# Public procs are exported and starts with lowercase
#
# Needed utilities package
package require opt 0.4.1;
# Create the safe namespace
namespace eval ::safe {
# Exported API:
namespace export interpCreate interpInit interpConfigure interpDelete \
interpAddToAccessPath interpFindInAccessPath setLogCmd
####
#
# Setup the arguments parsing
#
####
# Share the descriptions
set temp [::tcl::OptKeyRegister {
{-accessPath -list {} "access path for the slave"}
{-noStatics "prevent loading of statically linked pkgs"}
{-statics true "loading of statically linked pkgs"}
{-nestedLoadOk "allow nested loading"}
{-nested false "nested loading"}
{-deleteHook -script {} "delete hook"}
}]
# create case (slave is optional)
::tcl::OptKeyRegister {
{?slave? -name {} "name of the slave (optional)"}
} ::safe::interpCreate
# adding the flags sub programs to the command program
# (relying on Opt's internal implementation details)
lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp)
# init and configure (slave is needed)
::tcl::OptKeyRegister {
{slave -name {} "name of the slave"}
} ::safe::interpIC
# adding the flags sub programs to the command program
# (relying on Opt's internal implementation details)
lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp)
# temp not needed anymore
::tcl::OptKeyDelete $temp
# Helper function to resolve the dual way of specifying staticsok
# (either by -noStatics or -statics 0)
proc InterpStatics {} {
foreach v {Args statics noStatics} {
upvar $v $v
}
set flag [::tcl::OptProcArgGiven -noStatics];
if {$flag && ($noStatics == $statics)
&& ([::tcl::OptProcArgGiven -statics])} {
return -code error\
"conflicting values given for -statics and -noStatics"
}
if {$flag} {
return [expr {!$noStatics}]
} else {
return $statics
}
}
# Helper function to resolve the dual way of specifying nested loading
# (either by -nestedLoadOk or -nested 1)
proc InterpNested {} {
foreach v {Args nested nestedLoadOk} {
upvar $v $v
}
set flag [::tcl::OptProcArgGiven -nestedLoadOk];
# note that the test here is the opposite of the "InterpStatics"
# one (it is not -noNested... because of the wanted default value)
if {$flag && ($nestedLoadOk != $nested)
&& ([::tcl::OptProcArgGiven -nested])} {
return -code error\
"conflicting values given for -nested and -nestedLoadOk"
}
if {$flag} {
# another difference with "InterpStatics"
return $nestedLoadOk
} else {
return $nested
}
}
####
#
# API entry points that needs argument parsing :
#
####
# Interface/entry point function and front end for "Create"
proc interpCreate {args} {
set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
InterpCreate $slave $accessPath \
[InterpStatics] [InterpNested] $deleteHook
}
proc interpInit {args} {
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
if {![::interp exists $slave]} {
return -code error "\"$slave\" is not an interpreter"
}
InterpInit $slave $accessPath \
[InterpStatics] [InterpNested] $deleteHook;
}
proc CheckInterp {slave} {
if {![IsInterp $slave]} {
return -code error \
"\"$slave\" is not an interpreter managed by ::safe::"
}
}
# Interface/entry point function and front end for "Configure"
# This code is awfully pedestrian because it would need
# more coupling and support between the way we store the
# configuration values in safe::interp's and the Opt package
# Obviously we would like an OptConfigure
# to avoid duplicating all this code everywhere. -> TODO
# (the app should share or access easily the program/value
# stored by opt)
# This is even more complicated by the boolean flags with no values
# that we had the bad idea to support for the sake of user simplicity
# in create/init but which makes life hard in configure...
# So this will be hopefully written and some integrated with opt1.0
# (hopefully for tcl8.1 ?)
proc interpConfigure {args} {
switch [llength $args] {
1 {
# If we have exactly 1 argument
# the semantic is to return all the current configuration
# We still call OptKeyParse though we know that "slave"
# is our given argument because it also checks
# for the "-help" option.
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
CheckInterp $slave
set res {}
lappend res [list -accessPath [Set [PathListName $slave]]]
lappend res [list -statics [Set [StaticsOkName $slave]]]
lappend res [list -nested [Set [NestedOkName $slave]]]
lappend res [list -deleteHook [Set [DeleteHookName $slave]]]
join $res
}
2 {
# If we have exactly 2 arguments
# the semantic is a "configure get"
::tcl::Lassign $args slave arg
# get the flag sub program (we 'know' about Opt's internal
# representation of data)
set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]
set hits [::tcl::OptHits desc $arg]
if {$hits > 1} {
return -code error [::tcl::OptAmbigous $desc $arg]
} elseif {$hits == 0} {
return -code error [::tcl::OptFlagUsage $desc $arg]
}
CheckInterp $slave
set item [::tcl::OptCurDesc $desc]
set name [::tcl::OptName $item]
switch -exact -- $name {
-accessPath {
return [list -accessPath [Set [PathListName $slave]]]
}
-statics {
return [list -statics [Set [StaticsOkName $slave]]]
}
-nested {
return [list -nested [Set [NestedOkName $slave]]]
}
-deleteHook {
return [list -deleteHook [Set [DeleteHookName $slave]]]
}
-noStatics {
# it is most probably a set in fact
# but we would need then to jump to the set part
# and it is not *sure* that it is a set action
# that the user want, so force it to use the
# unambigous -statics ?value? instead:
return -code error\
"ambigous query (get or set -noStatics ?)\
use -statics instead"
}
-nestedLoadOk {
return -code error\
"ambigous query (get or set -nestedLoadOk ?)\
use -nested instead"
}
default {
return -code error "unknown flag $name (bug)"
}
}
}
default {
# Otherwise we want to parse the arguments like init and create
# did
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
CheckInterp $slave
# Get the current (and not the default) values of
# whatever has not been given:
if {![::tcl::OptProcArgGiven -accessPath]} {
set doreset 1
set accessPath [Set [PathListName $slave]]
} else {
set doreset 0
}
if {(![::tcl::OptProcArgGiven -statics]) \
&& (![::tcl::OptProcArgGiven -noStatics]) } {
set statics [Set [StaticsOkName $slave]]
} else {
set statics [InterpStatics]
}
if {([::tcl::OptProcArgGiven -nested]) \
|| ([::tcl::OptProcArgGiven -nestedLoadOk]) } {
set nested [InterpNested]
} else {
set nested [Set [NestedOkName $slave]]
}
if {![::tcl::OptProcArgGiven -deleteHook]} {
set deleteHook [Set [DeleteHookName $slave]]
}
# we can now reconfigure :
InterpSetConfig $slave $accessPath $statics $nested $deleteHook
# auto_reset the slave (to completly synch the new access_path)
if {$doreset} {
if {[catch {::interp eval $slave {auto_reset}} msg]} {
Log $slave "auto_reset failed: $msg"
} else {
Log $slave "successful auto_reset" NOTICE
}
}
}
}
}
####
#
# Functions that actually implements the exported APIs
#
####
#
# safe::InterpCreate : doing the real job
#
# This procedure creates a safe slave and initializes it with the
# safe base aliases.
# NB: slave name must be simple alphanumeric string, no spaces,
# no (), no {},... {because the state array is stored as part of the name}
#
# Returns the slave name.
#
# Optional Arguments :
# + slave name : if empty, generated name will be used
# + access_path: path list controlling where load/source can occur,
# if empty: the master auto_path will be used.
# + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx)
# if 1 :static packages are ok.
# + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub)
# if 1 : multiple levels are ok.
# use the full name and no indent so auto_mkIndex can find us
proc ::safe::InterpCreate {
slave
access_path
staticsok
nestedok
deletehook
} {
# Create the slave.
if {$slave ne ""} {
::interp create -safe $slave
} else {
# empty argument: generate slave name
set slave [::interp create -safe]
}
Log $slave "Created" NOTICE
# Initialize it. (returns slave name)
InterpInit $slave $access_path $staticsok $nestedok $deletehook
}
#
# InterpSetConfig (was setAccessPath) :
# Sets up slave virtual auto_path and corresponding structure
# within the master. Also sets the tcl_library in the slave
# to be the first directory in the path.
# Nb: If you change the path after the slave has been initialized
# you probably need to call "auto_reset" in the slave in order that it
# gets the right auto_index() array values.
proc ::safe::InterpSetConfig {slave access_path staticsok\
nestedok deletehook} {
# determine and store the access path if empty
if {[string equal "" $access_path]} {
set access_path [uplevel #0 set auto_path]
# Make sure that tcl_library is in auto_path
# and at the first position (needed by setAccessPath)
set where [lsearch -exact $access_path [info library]]
if {$where == -1} {
# not found, add it.
set access_path [concat [list [info library]] $access_path]
Log $slave "tcl_library was not in auto_path,\
added it to slave's access_path" NOTICE
} elseif {$where != 0} {
# not first, move it first
set access_path [concat [list [info library]]\
[lreplace $access_path $where $where]]
Log $slave "tcl_libray was not in first in auto_path,\
moved it to front of slave's access_path" NOTICE
}
# Add 1st level sub dirs (will searched by auto loading from tcl
# code in the slave using glob and thus fail, so we add them
# here so by default it works the same).
set access_path [AddSubDirs $access_path]
}
Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\
nestedok=$nestedok deletehook=($deletehook)" NOTICE
# clear old autopath if it existed
set nname [PathNumberName $slave]
if {[Exists $nname]} {
set n [Set $nname]
for {set i 0} {$i<$n} {incr i} {
Unset [PathToken $i $slave]
}
}
# build new one
set slave_auto_path {}
set i 0
foreach dir $access_path {
Set [PathToken $i $slave] $dir
lappend slave_auto_path "\$[PathToken $i]"
incr i
}
Set $nname $i
Set [PathListName $slave] $access_path
Set [VirtualPathListName $slave] $slave_auto_path
Set [StaticsOkName $slave] $staticsok
Set [NestedOkName $slave] $nestedok
Set [DeleteHookName $slave] $deletehook
SyncAccessPath $slave
}
#
#
# FindInAccessPath:
# Search for a real directory and returns its virtual Id
# (including the "$")
proc ::safe::interpFindInAccessPath {slave path} {
set access_path [GetAccessPath $slave]
set where [lsearch -exact $access_path $path]
if {$where == -1} {
return -code error "$path not found in access path $access_path"
}
return "\$[PathToken $where]"
}
#
# addToAccessPath:
# add (if needed) a real directory to access path
# and return its virtual token (including the "$").
proc ::safe::interpAddToAccessPath {slave path} {
# first check if the directory is already in there
if {![catch {interpFindInAccessPath $slave $path} res]} {
return $res
}
# new one, add it:
set nname [PathNumberName $slave]
set n [Set $nname]
Set [PathToken $n $slave] $path
set token "\$[PathToken $n]"
Lappend [VirtualPathListName $slave] $token
Lappend [PathListName $slave] $path
Set $nname [expr {$n+1}]
SyncAccessPath $slave
return $token
}
# This procedure applies the initializations to an already existing
# interpreter. It is useful when you want to install the safe base
# aliases into a preexisting safe interpreter.
proc ::safe::InterpInit {
slave
access_path
staticsok
nestedok
deletehook
} {
# Configure will generate an access_path when access_path is
# empty.
InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook
# These aliases let the slave load files to define new commands
# NB we need to add [namespace current], aliases are always
# absolute paths.
::interp alias $slave source {} [namespace current]::AliasSource $slave
::interp alias $slave load {} [namespace current]::AliasLoad $slave
# This alias lets the slave use the encoding names, convertfrom,
# convertto, and system, but not "encoding system <name>" to set
# the system encoding.
::interp alias $slave encoding {} [namespace current]::AliasEncoding \
$slave
# This alias lets the slave have access to a subset of the 'file'
# command functionality.
AliasSubset $slave file file dir.* join root.* ext.* tail \
path.* split
# This alias interposes on the 'exit' command and cleanly terminates
# the slave.
::interp alias $slave exit {} [namespace current]::interpDelete $slave
# The allowed slave variables already have been set
# by Tcl_MakeSafe(3)
# Source init.tcl into the slave, to get auto_load and other
# procedures defined:
# We don't try to use the -rsrc on the mac because it would get
# confusing if you would want to customize init.tcl
# for a given set of safe slaves, on all the platforms
# you just need to give a specific access_path and
# the mac should be no exception. As there is no
# obvious full "safe ressources" design nor implementation
# for the mac, safe interps there will just don't
# have that ability. (A specific app can still reenable
# that using custom aliases if they want to).
# It would also make the security analysis and the Safe Tcl security
# model platform dependant and thus more error prone.
if {[catch {::interp eval $slave\
{source [file join $tcl_library init.tcl]}} msg]} {
Log $slave "can't source init.tcl ($msg)"
error "can't source init.tcl into slave $slave ($msg)"
}
return $slave
}
# Add (only if needed, avoid duplicates) 1 level of
# sub directories to an existing path list.
# Also removes non directories from the returned list.
proc AddSubDirs {pathList} {
set res {}
foreach dir $pathList {
if {[file isdirectory $dir]} {
# check that we don't have it yet as a children
# of a previous dir
if {[lsearch -exact $res $dir]<0} {
lappend res $dir
}
foreach sub [glob -directory $dir -nocomplain *] {
if {([file isdirectory $sub]) \
&& ([lsearch -exact $res $sub]<0) } {
# new sub dir, add it !
lappend res $sub
}
}
}
}
return $res
}
# This procedure deletes a safe slave managed by Safe Tcl and
# cleans up associated state:
proc ::safe::interpDelete {slave} {
Log $slave "About to delete" NOTICE
# If the slave has a cleanup hook registered, call it.
# check the existance because we might be called to delete an interp
# which has not been registered with us at all
set hookname [DeleteHookName $slave]
if {[Exists $hookname]} {
set hook [Set $hookname]
if {![::tcl::Lempty $hook]} {
# remove the hook now, otherwise if the hook
# calls us somehow, we'll loop
Unset $hookname
if {[catch {eval $hook [list $slave]} err]} {
Log $slave "Delete hook error ($err)"
}
}
}
# Discard the global array of state associated with the slave, and
# delete the interpreter.
set statename [InterpStateName $slave]
if {[Exists $statename]} {
Unset $statename
}
# if we have been called twice, the interp might have been deleted
# already
if {[::interp exists $slave]} {
::interp delete $slave
Log $slave "Deleted" NOTICE
}
return
}
# Set (or get) the loging mecanism
proc ::safe::setLogCmd {args} {
variable Log
if {[llength $args] == 0} {
return $Log
} else {
if {[llength $args] == 1} {
set Log [lindex $args 0]
} else {
set Log $args
}
}
}
# internal variable
variable Log {}
# ------------------- END OF PUBLIC METHODS ------------
#
# sets the slave auto_path to the master recorded value.
# also sets tcl_library to the first token of the virtual path.
#
proc SyncAccessPath {slave} {
set slave_auto_path [Set [VirtualPathListName $slave]]
::interp eval $slave [list set auto_path $slave_auto_path]
Log $slave "auto_path in $slave has been set to $slave_auto_path"\
NOTICE
::interp eval $slave [list set tcl_library [lindex $slave_auto_path 0]]
}
# base name for storing all the slave states
# the array variable name for slave foo is thus "Sfoo"
# and for sub slave {foo bar} "Sfoo bar" (spaces are handled
# ok everywhere (or should))
# We add the S prefix to avoid that a slave interp called "Log"
# would smash our "Log" variable.
proc InterpStateName {slave} {
return "S$slave"
}
# Check that the given slave is "one of us"
proc IsInterp {slave} {
expr {[Exists [InterpStateName $slave]] && [::interp exists $slave]}
}
# returns the virtual token for directory number N
# if the slave argument is given,
# it will return the corresponding master global variable name
proc PathToken {n {slave ""}} {
if {$slave ne ""} {
return "[InterpStateName $slave](access_path,$n)"
} else {
# We need to have a ":" in the token string so
# [file join] on the mac won't turn it into a relative
# path.
return "p(:$n:)"
}
}
# returns the variable name of the complete path list
proc PathListName {slave} {
return "[InterpStateName $slave](access_path)"
}
# returns the variable name of the complete path list
proc VirtualPathListName {slave} {
return "[InterpStateName $slave](access_path_slave)"
}
# returns the variable name of the number of items
proc PathNumberName {slave} {
return "[InterpStateName $slave](access_path,n)"
}
# returns the staticsok flag var name
proc StaticsOkName {slave} {
return "[InterpStateName $slave](staticsok)"
}
# returns the nestedok flag var name
proc NestedOkName {slave} {
return "[InterpStateName $slave](nestedok)"
}
# Run some code at the namespace toplevel
proc Toplevel {args} {
namespace eval [namespace current] $args
}
# set/get values
proc Set {args} {
eval [list Toplevel set] $args
}
# lappend on toplevel vars
proc Lappend {args} {
eval [list Toplevel lappend] $args
}
# unset a var/token (currently just an global level eval)
proc Unset {args} {
eval [list Toplevel unset] $args
}
# test existance
proc Exists {varname} {
Toplevel info exists $varname
}
# short cut for access path getting
proc GetAccessPath {slave} {
Set [PathListName $slave]
}
# short cut for statics ok flag getting
proc StaticsOk {slave} {
Set [StaticsOkName $slave]
}
# short cut for getting the multiples interps sub loading ok flag
proc NestedOk {slave} {
Set [NestedOkName $slave]
}
# interp deletion storing hook name
proc DeleteHookName {slave} {
return [InterpStateName $slave](cleanupHook)
}
#
# translate virtual path into real path
#
proc TranslatePath {slave path} {
# somehow strip the namespaces 'functionality' out (the danger
# is that we would strip valid macintosh "../" queries... :
if {[regexp {(::)|(\.\.)} $path]} {
error "invalid characters in path $path"
}
set n [expr {[Set [PathNumberName $slave]]-1}]
for {} {$n>=0} {incr n -1} {
# fill the token virtual names with their real value
set [PathToken $n] [Set [PathToken $n $slave]]
}
# replaces the token by their value
subst -nobackslashes -nocommands $path
}
# Log eventually log an error
# to enable error logging, set Log to {puts stderr} for instance
proc Log {slave msg {type ERROR}} {
variable Log
if {[info exists Log] && [llength $Log]} {
eval $Log [list "$type for slave $slave : $msg"]
}
}
# file name control (limit access to files/ressources that should be
# a valid tcl source file)
proc CheckFileName {slave file} {
# This used to limit what can be sourced to ".tcl" and forbid files
# with more than 1 dot and longer than 14 chars, but I changed that
# for 8.4 as a safe interp has enough internal protection already
# to allow sourcing anything. - hobbs
if {![file exists $file]} {
# don't tell the file path
error "no such file or directory"
}
if {![file readable $file]} {
# don't tell the file path
error "not readable"
}
}
# AliasSource is the target of the "source" alias in safe interpreters.
proc AliasSource {slave args} {
set argc [llength $args]
# Allow only "source filename"
# (and not mac specific -rsrc for instance - see comment in ::init
# for current rationale)
if {$argc != 1} {
set msg "wrong # args: should be \"source fileName\""
Log $slave "$msg ($args)"
return -code error $msg
}
set file [lindex $args 0]
# get the real path from the virtual one.
if {[catch {set file [TranslatePath $slave $file]} msg]} {
Log $slave $msg
return -code error "permission denied"
}
# check that the path is in the access path of that slave
if {[catch {FileInAccessPath $slave $file} msg]} {
Log $slave $msg
return -code error "permission denied"
}
# do the checks on the filename :
if {[catch {CheckFileName $slave $file} msg]} {
Log $slave "$file:$msg"
return -code error $msg
}
# passed all the tests , lets source it:
if {[catch {::interp invokehidden $slave source $file} msg]} {
Log $slave $msg
return -code error "script error"
}
return $msg
}
# AliasLoad is the target of the "load" alias in safe interpreters.
proc AliasLoad {slave file args} {
set argc [llength $args]
if {$argc > 2} {
set msg "load error: too many arguments"
Log $slave "$msg ($argc) {$file $args}"
return -code error $msg
}
# package name (can be empty if file is not).
set package [lindex $args 0]
# Determine where to load. load use a relative interp path
# and {} means self, so we can directly and safely use passed arg.
set target [lindex $args 1]
if {[string length $target]} {
# we will try to load into a sub sub interp
# check that we want to authorize that.
if {![NestedOk $slave]} {
Log $slave "loading to a sub interp (nestedok)\
disabled (trying to load $package to $target)"
return -code error "permission denied (nested load)"
}
}
# Determine what kind of load is requested
if {[string length $file] == 0} {
# static package loading
if {[string length $package] == 0} {
set msg "load error: empty filename and no package name"
Log $slave $msg
return -code error $msg
}
if {![StaticsOk $slave]} {
Log $slave "static packages loading disabled\
(trying to load $package to $target)"
return -code error "permission denied (static package)"
}
} else {
# file loading
# get the real path from the virtual one.
if {[catch {set file [TranslatePath $slave $file]} msg]} {
Log $slave $msg
return -code error "permission denied"
}
# check the translated path
if {[catch {FileInAccessPath $slave $file} msg]} {
Log $slave $msg
return -code error "permission denied (path)"
}
}
if {[catch {::interp invokehidden\
$slave load $file $package $target} msg]} {
Log $slave $msg
return -code error $msg
}
return $msg
}
# FileInAccessPath raises an error if the file is not found in
# the list of directories contained in the (master side recorded) slave's
# access path.
# the security here relies on "file dirname" answering the proper
# result.... needs checking ?
proc FileInAccessPath {slave file} {
set access_path [GetAccessPath $slave]
if {[file isdirectory $file]} {
error "\"$file\": is a directory"
}
set parent [file dirname $file]
if {[lsearch -exact $access_path $parent] == -1} {
error "\"$file\": not in access_path"
}
}
# This procedure enables access from a safe interpreter to only a subset of
# the subcommands of a command:
proc Subset {slave command okpat args} {
set subcommand [lindex $args 0]
if {[regexp $okpat $subcommand]} {
return [eval [list $command $subcommand] [lrange $args 1 end]]
}
set msg "not allowed to invoke subcommand $subcommand of $command"
Log $slave $msg
error $msg
}
# This procedure installs an alias in a slave that invokes "safesubset"
# in the master to execute allowed subcommands. It precomputes the pattern
# of allowed subcommands; you can use wildcards in the pattern if you wish
# to allow subcommand abbreviation.
#
# Syntax is: AliasSubset slave alias target subcommand1 subcommand2...
proc AliasSubset {slave alias target args} {
set pat ^(; set sep ""
foreach sub $args {
append pat $sep$sub
set sep |
}
append pat )\$
::interp alias $slave $alias {}\
[namespace current]::Subset $slave $target $pat
}
# AliasEncoding is the target of the "encoding" alias in safe interpreters.
proc AliasEncoding {slave args} {
set argc [llength $args]
set okpat "^(name.*|convert.*)\$"
set subcommand [lindex $args 0]
if {[regexp $okpat $subcommand]} {
return [eval ::interp invokehidden $slave encoding $subcommand \
[lrange $args 1 end]]
}
if {[string match $subcommand system]} {
if {$argc == 1} {
# passed all the tests , lets source it:
if {[catch {::interp invokehidden \
$slave encoding system} msg]} {
Log $slave $msg
return -code error "script error"
}
} else {
set msg "wrong # args: should be \"encoding system\""
Log $slave $msg
error $msg
}
} else {
set msg "wrong # args: should be \"encoding option ?arg ...?\""
Log $slave $msg
error $msg
}
return $msg
}
}
gradint-build/PocketPC/Program Files/lib/tcl8.4/tclIndex deleted 100644 → 0
View file @ 14df51ec
# 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(auto_reset) [list source [file join $dir auto.tcl]]
set auto_index(tcl_findLibrary) [list source [file join $dir auto.tcl]]
set auto_index(auto_mkindex) [list source [file join $dir auto.tcl]]
set auto_index(auto_mkindex_old) [list source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::init) [list source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::cleanup) [list source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::mkindex) [list source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::hook) [list source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::slavehook) [list source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::command) [list source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::commandInit) [list source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::fullname) [list source [file join $dir auto.tcl]]
set auto_index(history) [list source [file join $dir history.tcl]]
set auto_index(::tcl::HistAdd) [list source [file join $dir history.tcl]]
set auto_index(::tcl::HistKeep) [list source [file join $dir history.tcl]]
set auto_index(::tcl::HistClear) [list source [file join $dir history.tcl]]
set auto_index(::tcl::HistInfo) [list source [file join $dir history.tcl]]
set auto_index(::tcl::HistRedo) [list source [file join $dir history.tcl]]
set auto_index(::tcl::HistIndex) [list source [file join $dir history.tcl]]
set auto_index(::tcl::HistEvent) [list source [file join $dir history.tcl]]
set auto_index(::tcl::HistChange) [list source [file join $dir history.tcl]]
set auto_index(tclLdAout) [list source [file join $dir ldAout.tcl]]
set auto_index(pkg_compareExtension) [list source [file join $dir package.tcl]]
set auto_index(pkg_mkIndex) [list source [file join $dir package.tcl]]
set auto_index(tclPkgSetup) [list source [file join $dir package.tcl]]
set auto_index(tclPkgUnknown) [list source [file join $dir package.tcl]]
set auto_index(::tcl::MacOSXPkgUnknown) [list source [file join $dir package.tcl]]
set auto_index(::tcl::MacPkgUnknown) [list source [file join $dir package.tcl]]
set auto_index(::pkg::create) [list source [file join $dir package.tcl]]
set auto_index(parray) [list source [file join $dir parray.tcl]]
set auto_index(::safe::InterpStatics) [list source [file join $dir safe.tcl]]
set auto_index(::safe::InterpNested) [list source [file join $dir safe.tcl]]
set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]]
set auto_index(::safe::interpInit) [list source [file join $dir safe.tcl]]
set auto_index(::safe::CheckInterp) [list source [file join $dir safe.tcl]]
set auto_index(::safe::interpConfigure) [list source [file join $dir safe.tcl]]
set auto_index(::safe::InterpCreate) [list source [file join $dir safe.tcl]]
set auto_index(::safe::InterpSetConfig) [list source [file join $dir safe.tcl]]
set auto_index(::safe::interpFindInAccessPath) [list source [file join $dir safe.tcl]]
set auto_index(::safe::interpAddToAccessPath) [list source [file join $dir safe.tcl]]
set auto_index(::safe::InterpInit) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AddSubDirs) [list source [file join $dir safe.tcl]]
set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]]
set auto_index(::safe::setLogCmd) [list source [file join $dir safe.tcl]]
set auto_index(::safe::SyncAccessPath) [list source [file join $dir safe.tcl]]
set auto_index(::safe::InterpStateName) [list source [file join $dir safe.tcl]]
set auto_index(::safe::IsInterp) [list source [file join $dir safe.tcl]]
set auto_index(::safe::PathToken) [list source [file join $dir safe.tcl]]
set auto_index(::safe::PathListName) [list source [file join $dir safe.tcl]]
set auto_index(::safe::VirtualPathListName) [list source [file join $dir safe.tcl]]
set auto_index(::safe::PathNumberName) [list source [file join $dir safe.tcl]]
set auto_index(::safe::StaticsOkName) [list source [file join $dir safe.tcl]]
set auto_index(::safe::NestedOkName) [list source [file join $dir safe.tcl]]
set auto_index(::safe::Toplevel) [list source [file join $dir safe.tcl]]
set auto_index(::safe::Set) [list source [file join $dir safe.tcl]]
set auto_index(::safe::Lappend) [list source [file join $dir safe.tcl]]
set auto_index(::safe::Unset) [list source [file join $dir safe.tcl]]
set auto_index(::safe::Exists) [list source [file join $dir safe.tcl]]
set auto_index(::safe::GetAccessPath) [list source [file join $dir safe.tcl]]
set auto_index(::safe::StaticsOk) [list source [file join $dir safe.tcl]]
set auto_index(::safe::NestedOk) [list source [file join $dir safe.tcl]]
set auto_index(::safe::DeleteHookName) [list source [file join $dir safe.tcl]]
set auto_index(::safe::TranslatePath) [list source [file join $dir safe.tcl]]
set auto_index(::safe::Log) [list source [file join $dir safe.tcl]]
set auto_index(::safe::CheckFileName) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasSource) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasLoad) [list source [file join $dir safe.tcl]]
set auto_index(::safe::FileInAccessPath) [list source [file join $dir safe.tcl]]
set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]]
set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]]
set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]]
set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]]
set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]]
set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]]
gradint-build/PocketPC/Program Files/lib/tcl8.4/word.tcl deleted 100644 → 0
View file @ 14df51ec
# word.tcl --
#
# This file defines various procedures for computing word boundaries
# in strings. This file is primarily needed so Tk text and entry
# widgets behave properly for different platforms.
#
# Copyright (c) 1996 by Sun Microsystems, Inc.
# Copyright (c) 1998 by Scritpics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: word.tcl,v 1.7 2002/11/01 00:28:51 andreas_kupries Exp $
# The following variables are used to determine which characters are
# interpreted as white space.
if {[string equal $::tcl_platform(platform) "windows"]} {
# Windows style - any but a unicode space char
set tcl_wordchars "\\S"
set tcl_nonwordchars "\\s"
} else {
# Motif style - any unicode word char (number, letter, or underscore)
set tcl_wordchars "\\w"
set tcl_nonwordchars "\\W"
}
# tcl_wordBreakAfter --
#
# This procedure returns the index of the first word boundary
# after the starting point in the given string, or -1 if there
# are no more boundaries in the given string. The index returned refers
# to the first character of the pair that comprises a boundary.
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_wordBreakAfter {str start} {
global tcl_nonwordchars tcl_wordchars
set str [string range $str $start end]
if {[regexp -indices "$tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars" $str result]} {
return [expr {[lindex $result 1] + $start}]
}
return -1
}
# tcl_wordBreakBefore --
#
# This procedure returns the index of the first word boundary
# before the starting point in the given string, or -1 if there
# are no more boundaries in the given string. The index returned
# refers to the second character of the pair that comprises a boundary.
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_wordBreakBefore {str start} {
global tcl_nonwordchars tcl_wordchars
if {[string equal $start end]} {
set start [string length $str]
}
if {[regexp -indices "^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)" [string range $str 0 $start] result]} {
return [lindex $result 1]
}
return -1
}
# tcl_endOfWord --
#
# This procedure returns the index of the first end-of-word location
# after a starting index in the given string. An end-of-word location
# is defined to be the first whitespace character following the first
# non-whitespace character after the starting point. Returns -1 if
# there are no more words after the starting point.
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_endOfWord {str start} {
global tcl_nonwordchars tcl_wordchars
if {[regexp -indices "$tcl_nonwordchars*$tcl_wordchars+$tcl_nonwordchars" \
[string range $str $start end] result]} {
return [expr {[lindex $result 1] + $start}]
}
return -1
}
# tcl_startOfNextWord --
#
# This procedure returns the index of the first start-of-word location
# after a starting index in the given string. A start-of-word
# location is defined to be a non-whitespace character following a
# whitespace character. Returns -1 if there are no more start-of-word
# locations after the starting point.
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_startOfNextWord {str start} {
global tcl_nonwordchars tcl_wordchars
if {[regexp -indices "$tcl_wordchars*$tcl_nonwordchars+$tcl_wordchars" \
[string range $str $start end] result]} {
return [expr {[lindex $result 1] + $start}]
}
return -1
}
# tcl_startOfPreviousWord --
#
# This procedure returns the index of the first start-of-word location
# before a starting index in the given string.
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_startOfPreviousWord {str start} {
global tcl_nonwordchars tcl_wordchars
if {[string equal $start end]} {
set start [string length $str]
}
if {[regexp -indices \
"$tcl_nonwordchars*($tcl_wordchars+)$tcl_nonwordchars*\$" \
[string range $str 0 [expr {$start - 1}]] result word]} {
return [lindex $word 0]
}
return -1
}
gradint-build/PocketPC/Program Files/lib/tk8.4/bgerror.tcl deleted 100644 → 0
View file @ 14df51ec
# bgerror.tcl --
#
# Implementation of the bgerror procedure. It posts a dialog box with
# the error message and gives the user a chance to see a more detailed
# stack trace, and possible do something more interesting with that
# trace (like save it to a log). This is adapted from work done by
# Donal K. Fellows.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# All rights reserved.
#
# RCS: @(#) $Id: bgerror.tcl,v 1.23.2.1 2003/04/25 20:11:06 hobbs Exp $
# $Id: bgerror.tcl,v 1.23.2.1 2003/04/25 20:11:06 hobbs Exp $
namespace eval ::tk {
namespace eval dialog {
namespace eval error {
namespace import ::tk::msgcat::*
namespace export bgerror
option add *ErrorDialog.function.text [mc "Save To Log"] \
widgetDefault
option add *ErrorDialog.function.command [namespace code SaveToLog]
}
}
}
proc ::tk::dialog::error::Return {} {
variable button
.bgerrorDialog.ok configure -state active -relief sunken
update idletasks
after 100
set button 0
}
proc ::tk::dialog::error::Details {} {
set w .bgerrorDialog
set caption [option get $w.function text {}]
set command [option get $w.function command {}]
if { ($caption eq "") || ($command eq "") } {
grid forget $w.function
}
$w.function configure -text $caption -command \
"$command [list [.bgerrorDialog.top.info.text get 1.0 end]]"
grid $w.top.info - -sticky nsew -padx 3m -pady 3m
}
proc ::tk::dialog::error::SaveToLog {text} {
if { $::tcl_platform(platform) eq "windows" } {
set allFiles *.*
} else {
set allFiles *
}
set types [list \
[list [mc "Log Files"] .log] \
[list [mc "Text Files"] .txt] \
[list [mc "All Files"] $allFiles] \
]
set filename [tk_getSaveFile -title [mc "Select Log File"] \
-filetypes $types -defaultextension .log -parent .bgerrorDialog]
if {![string length $filename]} {
return
}
set f [open $filename w]
puts -nonewline $f $text
close $f
}
proc ::tk::dialog::error::Destroy {w} {
if {$w eq ".bgerrorDialog"} {
variable button
set button -1
}
}
# ::tk::dialog::error::bgerror --
# This is the default version of bgerror.
# It tries to execute tkerror, if that fails it posts a dialog box containing
# the error message and gives the user a chance to ask to see a stack
# trace.
# Arguments:
# err - The error message.
proc ::tk::dialog::error::bgerror err {
global errorInfo tcl_platform
variable button
set info $errorInfo
set ret [catch {::tkerror $err} msg];
if {$ret != 1} {return -code $ret $msg}
# Ok the application's tkerror either failed or was not found
# we use the default dialog then :
if {($tcl_platform(platform) eq "macintosh")
|| ([tk windowingsystem] eq "aqua")} {
set ok [mc Ok]
set messageFont system
set textRelief flat
set textHilight 0
} else {
set ok [mc OK]
set messageFont {Times -18}
set textRelief sunken
set textHilight 1
}
# Truncate the message if it is too wide (longer than 30 characacters) or
# too tall (more than 4 newlines). Truncation occurs at the first point at
# which one of those conditions is met.
set displayedErr ""
set lines 0
foreach line [split $err \n] {
if { [string length $line] > 30 } {
append displayedErr "[string range $line 0 29]..."
break
}
if { $lines > 4 } {
append displayedErr "..."
break
} else {
append displayedErr "${line}\n"
}
incr lines
}
set w .bgerrorDialog
set title [mc "Application Error"]
set text [mc {Error: %1$s} $err]
set buttons [list ok $ok dismiss [mc "Skip Messages"] \
function [mc "Details >>"]]
# 1. Create the top-level window and divide it into top
# and bottom parts.
catch {destroy .bgerrorDialog}
toplevel .bgerrorDialog -class ErrorDialog
wm title .bgerrorDialog $title
wm iconname .bgerrorDialog ErrorDialog
wm protocol .bgerrorDialog WM_DELETE_WINDOW { }
if {$tcl_platform(platform) eq "windows"} {
wm attributes .bgerrorDialog -topmost 1
}
if {($tcl_platform(platform) eq "macintosh")
|| ([tk windowingsystem] eq "aqua")} {
::tk::unsupported::MacWindowStyle style .bgerrorDialog dBoxProc
}
frame .bgerrorDialog.bot
frame .bgerrorDialog.top
if {[tk windowingsystem] eq "x11"} {
.bgerrorDialog.bot configure -relief raised -bd 1
.bgerrorDialog.top configure -relief raised -bd 1
}
pack .bgerrorDialog.bot -side bottom -fill both
pack .bgerrorDialog.top -side top -fill both -expand 1
set W [frame $w.top.info]
text $W.text \
-bd 2 \
-yscrollcommand [list $W.scroll set]\
-setgrid true \
-width 40 \
-height 10 \
-state normal \
-relief $textRelief \
-highlightthickness $textHilight \
-wrap char
scrollbar $W.scroll -relief sunken -command [list $W.text yview]
pack $W.scroll -side right -fill y
pack $W.text -side left -expand yes -fill both
$W.text insert 0.0 "$err\n$info"
$W.text mark set insert 0.0
bind $W.text <ButtonPress-1> { focus %W }
$W.text configure -state disabled
# 2. Fill the top part with bitmap and message
# Max-width of message is the width of the screen...
set wrapwidth [winfo screenwidth .bgerrorDialog]
# ...minus the width of the icon, padding and a fudge factor for
# the window manager decorations and aesthetics.
set wrapwidth [expr {$wrapwidth-60-[winfo pixels .bgerrorDialog 9m]}]
label .bgerrorDialog.msg -justify left -text $text -font $messageFont \
-wraplength $wrapwidth
if {($tcl_platform(platform) eq "macintosh")
|| ([tk windowingsystem] eq "aqua")} {
# On the Macintosh, use the stop bitmap
label .bgerrorDialog.bitmap -bitmap stop
} else {
# On other platforms, make the error icon
canvas .bgerrorDialog.bitmap -width 32 -height 32 -highlightthickness 0
.bgerrorDialog.bitmap create oval 0 0 31 31 -fill red -outline black
.bgerrorDialog.bitmap create line 9 9 23 23 -fill white -width 4
.bgerrorDialog.bitmap create line 9 23 23 9 -fill white -width 4
}
grid .bgerrorDialog.bitmap .bgerrorDialog.msg \
-in .bgerrorDialog.top \
-row 0 \
-padx 3m \
-pady 3m
grid configure .bgerrorDialog.msg -sticky nsw -padx {0 3m}
grid rowconfigure .bgerrorDialog.top 1 -weight 1
grid columnconfigure .bgerrorDialog.top 1 -weight 1
# 3. Create a row of buttons at the bottom of the dialog.
set i 0
foreach {name caption} $buttons {
button .bgerrorDialog.$name \
-text $caption \
-default normal \
-command [namespace code "set button $i"]
grid .bgerrorDialog.$name \
-in .bgerrorDialog.bot \
-column $i \
-row 0 \
-sticky ew \
-padx 10
grid columnconfigure .bgerrorDialog.bot $i -weight 1
# We boost the size of some Mac buttons for l&f
if {($tcl_platform(platform) eq "macintosh")
|| ([tk windowingsystem] eq "aqua")} {
if {($name eq "ok") || ($name eq "dismiss")} {
grid columnconfigure .bgerrorDialog.bot $i -minsize 79
}
}
incr i
}
# The "OK" button is the default for this dialog.
.bgerrorDialog.ok configure -default active
bind .bgerrorDialog <Return> [namespace code Return]
bind .bgerrorDialog <Destroy> [namespace code [list Destroy %W]]
.bgerrorDialog.function configure -command [namespace code Details]
# 6. Withdraw the window, then update all the geometry information
# so we know how big it wants to be, then center the window in the
# display and de-iconify it.
wm withdraw .bgerrorDialog
update idletasks
set parent [winfo parent .bgerrorDialog]
set width [winfo reqwidth .bgerrorDialog]
set height [winfo reqheight .bgerrorDialog]
set x [expr {([winfo screenwidth .bgerrorDialog] - $width )/2 - \
[winfo vrootx $parent]}]
set y [expr {([winfo screenheight .bgerrorDialog] - $height)/2 - \
[winfo vrooty $parent]}]
.bgerrorDialog configure -width $width
wm geometry .bgerrorDialog +$x+$y
wm deiconify .bgerrorDialog
# 7. Set a grab and claim the focus too.
set oldFocus [focus]
set oldGrab [grab current .bgerrorDialog]
if {$oldGrab != ""} {
set grabStatus [grab status $oldGrab]
}
grab .bgerrorDialog
focus .bgerrorDialog.ok
# 8. Wait for the user to respond, then restore the focus and
# return the index of the selected button. Restore the focus
# before deleting the window, since otherwise the window manager
# may take the focus away so we can't redirect it. Finally,
# restore any grab that was in effect.
vwait [namespace which -variable button]
set copy $button; # Save a copy...
catch {focus $oldFocus}
catch {destroy .bgerrorDialog}
if {$oldGrab ne ""} {
if {$grabStatus eq "global"} {
grab -global $oldGrab
} else {
grab $oldGrab
}
}
if {$copy == 1} {
return -code break
}
}
namespace eval :: {
# Fool the indexer
proc bgerror err {}
rename bgerror {}
namespace import ::tk::dialog::error::bgerror
}
gradint-build/PocketPC/Program Files/lib/tk8.4/button.tcl deleted 100644 → 0
View file @ 14df51ec
# button.tcl --
#
# This file defines the default bindings for Tk label, button,
# checkbutton, and radiobutton widgets and provides procedures
# that help in implementing those bindings.
#
# RCS: @(#) $Id: button.tcl,v 1.17 2002/09/04 02:05:52 hobbs Exp $
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 2002 ActiveState Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#-------------------------------------------------------------------------
# The code below creates the default class bindings for buttons.
#-------------------------------------------------------------------------
if {[string equal [tk windowingsystem] "classic"]
|| [string equal [tk windowingsystem] "aqua"]} {
bind Radiobutton <Enter> {
tk::ButtonEnter %W
}
bind Radiobutton <1> {
tk::ButtonDown %W
}
bind Radiobutton <ButtonRelease-1> {
tk::ButtonUp %W
}
bind Checkbutton <Enter> {
tk::ButtonEnter %W
}
bind Checkbutton <1> {
tk::ButtonDown %W
}
bind Checkbutton <ButtonRelease-1> {
tk::ButtonUp %W
}
}
if {[string equal "windows" $tcl_platform(platform)]} {
bind Checkbutton <equal> {
tk::CheckRadioInvoke %W select
}
bind Checkbutton <plus> {
tk::CheckRadioInvoke %W select
}
bind Checkbutton <minus> {
tk::CheckRadioInvoke %W deselect
}
bind Checkbutton <1> {
tk::CheckRadioDown %W
}
bind Checkbutton <ButtonRelease-1> {
tk::ButtonUp %W
}
bind Checkbutton <Enter> {
tk::CheckRadioEnter %W
}
bind Radiobutton <1> {
tk::CheckRadioDown %W
}
bind Radiobutton <ButtonRelease-1> {
tk::ButtonUp %W
}
bind Radiobutton <Enter> {
tk::CheckRadioEnter %W
}
}
if {[string equal "x11" [tk windowingsystem]]} {
bind Checkbutton <Return> {
if {!$tk_strictMotif} {
tk::CheckRadioInvoke %W
}
}
bind Radiobutton <Return> {
if {!$tk_strictMotif} {
tk::CheckRadioInvoke %W
}
}
bind Checkbutton <1> {
tk::CheckRadioInvoke %W
}
bind Radiobutton <1> {
tk::CheckRadioInvoke %W
}
bind Checkbutton <Enter> {
tk::ButtonEnter %W
}
bind Radiobutton <Enter> {
tk::ButtonEnter %W
}
}
bind Button <space> {
tk::ButtonInvoke %W
}
bind Checkbutton <space> {
tk::CheckRadioInvoke %W
}
bind Radiobutton <space> {
tk::CheckRadioInvoke %W
}
bind Button <FocusIn> {}
bind Button <Enter> {
tk::ButtonEnter %W
}
bind Button <Leave> {
tk::ButtonLeave %W
}
bind Button <1> {
tk::ButtonDown %W
}
bind Button <ButtonRelease-1> {
tk::ButtonUp %W
}
bind Checkbutton <FocusIn> {}
bind Checkbutton <Leave> {
tk::ButtonLeave %W
}
bind Radiobutton <FocusIn> {}
bind Radiobutton <Leave> {
tk::ButtonLeave %W
}
if {[string equal "windows" $tcl_platform(platform)]} {
#########################
# Windows implementation
#########################
# ::tk::ButtonEnter --
# The procedure below is invoked when the mouse pointer enters a
# button widget. It records the button we're in and changes the
# state of the button to active unless the button is disabled.
#
# Arguments:
# w - The name of the widget.
proc ::tk::ButtonEnter w {
variable ::tk::Priv
if {[$w cget -state] ne "disabled"} {
# If the mouse button is down, set the relief to sunken on entry.
# Overwise, if there's an -overrelief value, set the relief to that.
set Priv($w,relief) [$w cget -relief]
if {$Priv(buttonWindow) eq $w} {
$w configure -relief sunken -state active
set Priv($w,prelief) sunken
} elseif {[set over [$w cget -overrelief]] ne ""} {
$w configure -relief $over
set Priv($w,prelief) $over
}
}
set Priv(window) $w
}
# ::tk::ButtonLeave --
# The procedure below is invoked when the mouse pointer leaves a
# button widget. It changes the state of the button back to inactive.
# Restore any modified relief too.
#
# Arguments:
# w - The name of the widget.
proc ::tk::ButtonLeave w {
variable ::tk::Priv
if {[$w cget -state] ne "disabled"} {
$w configure -state normal
}
# Restore the original button relief if it was changed by Tk.
# That is signaled by the existence of Priv($w,prelief).
if {[info exists Priv($w,relief)]} {
if {[info exists Priv($w,prelief)] && \
$Priv($w,prelief) eq [$w cget -relief]} {
$w configure -relief $Priv($w,relief)
}
unset -nocomplain Priv($w,relief) Priv($w,prelief)
}
set Priv(window) ""
}
# ::tk::ButtonDown --
# The procedure below is invoked when the mouse button is pressed in
# a button widget. It records the fact that the mouse is in the button,
# saves the button's relief so it can be restored later, and changes
# the relief to sunken.
#
# Arguments:
# w - The name of the widget.
proc ::tk::ButtonDown w {
variable ::tk::Priv
# Only save the button's relief if it does not yet exist. If there
# is an overrelief setting, Priv($w,relief) will already have been set,
# and the current value of the -relief option will be incorrect.
if {![info exists Priv($w,relief)]} {
set Priv($w,relief) [$w cget -relief]
}
if {[$w cget -state] ne "disabled"} {
set Priv(buttonWindow) $w
$w configure -relief sunken -state active
set Priv($w,prelief) sunken
# If this button has a repeatdelay set up, get it going with an after
after cancel $Priv(afterId)
set delay [$w cget -repeatdelay]
set Priv(repeated) 0
if {$delay > 0} {
set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
}
}
}
# ::tk::ButtonUp --
# The procedure below is invoked when the mouse button is released
# in a button widget. It restores the button's relief and invokes
# the command as long as the mouse hasn't left the button.
#
# Arguments:
# w - The name of the widget.
proc ::tk::ButtonUp w {
variable ::tk::Priv
if {$Priv(buttonWindow) eq $w} {
set Priv(buttonWindow) ""
# Restore the button's relief if it was cached.
if {[info exists Priv($w,relief)]} {
if {[info exists Priv($w,prelief)] && \
$Priv($w,prelief) eq [$w cget -relief]} {
$w configure -relief $Priv($w,relief)
}
unset -nocomplain Priv($w,relief) Priv($w,prelief)
}
# Clean up the after event from the auto-repeater
after cancel $Priv(afterId)
if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} {
$w configure -state normal
# Only invoke the command if it wasn't already invoked by the
# auto-repeater functionality
if { $Priv(repeated) == 0 } {
uplevel #0 [list $w invoke]
}
}
}
}
# ::tk::CheckRadioEnter --
# The procedure below is invoked when the mouse pointer enters a
# checkbutton or radiobutton widget. It records the button we're in
# and changes the state of the button to active unless the button is
# disabled.
#
# Arguments:
# w - The name of the widget.
proc ::tk::CheckRadioEnter w {
variable ::tk::Priv
if {[$w cget -state] ne "disabled"} {
if {$Priv(buttonWindow) eq $w} {
$w configure -state active
}
if {[set over [$w cget -overrelief]] ne ""} {
set Priv($w,relief) [$w cget -relief]
set Priv($w,prelief) $over
$w configure -relief $over
}
}
set Priv(window) $w
}
# ::tk::CheckRadioDown --
# The procedure below is invoked when the mouse button is pressed in
# a button widget. It records the fact that the mouse is in the button,
# saves the button's relief so it can be restored later, and changes
# the relief to sunken.
#
# Arguments:
# w - The name of the widget.
proc ::tk::CheckRadioDown w {
variable ::tk::Priv
if {![info exists Priv($w,relief)]} {
set Priv($w,relief) [$w cget -relief]
}
if {[$w cget -state] ne "disabled"} {
set Priv(buttonWindow) $w
set Priv(repeated) 0
$w configure -state active
}
}
}
if {[string equal "x11" [tk windowingsystem]]} {
#####################
# Unix implementation
#####################
# ::tk::ButtonEnter --
# The procedure below is invoked when the mouse pointer enters a
# button widget. It records the button we're in and changes the
# state of the button to active unless the button is disabled.
#
# Arguments:
# w - The name of the widget.
proc ::tk::ButtonEnter {w} {
variable ::tk::Priv
if {[$w cget -state] ne "disabled"} {
# On unix the state is active just with mouse-over
$w configure -state active
# If the mouse button is down, set the relief to sunken on entry.
# Overwise, if there's an -overrelief value, set the relief to that.
set Priv($w,relief) [$w cget -relief]
if {$Priv(buttonWindow) eq $w} {
$w configure -relief sunken
set Priv($w,prelief) sunken
} elseif {[set over [$w cget -overrelief]] ne ""} {
$w configure -relief $over
set Priv($w,prelief) $over
}
}
set Priv(window) $w
}
# ::tk::ButtonLeave --
# The procedure below is invoked when the mouse pointer leaves a
# button widget. It changes the state of the button back to inactive.
# Restore any modified relief too.
#
# Arguments:
# w - The name of the widget.
proc ::tk::ButtonLeave w {
variable ::tk::Priv
if {[$w cget -state] ne "disabled"} {
$w configure -state normal
}
# Restore the original button relief if it was changed by Tk.
# That is signaled by the existence of Priv($w,prelief).
if {[info exists Priv($w,relief)]} {
if {[info exists Priv($w,prelief)] && \
$Priv($w,prelief) eq [$w cget -relief]} {
$w configure -relief $Priv($w,relief)
}
unset -nocomplain Priv($w,relief) Priv($w,prelief)
}
set Priv(window) ""
}
# ::tk::ButtonDown --
# The procedure below is invoked when the mouse button is pressed in
# a button widget. It records the fact that the mouse is in the button,
# saves the button's relief so it can be restored later, and changes
# the relief to sunken.
#
# Arguments:
# w - The name of the widget.
proc ::tk::ButtonDown w {
variable ::tk::Priv
# Only save the button's relief if it does not yet exist. If there
# is an overrelief setting, Priv($w,relief) will already have been set,
# and the current value of the -relief option will be incorrect.
if {![info exists Priv($w,relief)]} {
set Priv($w,relief) [$w cget -relief]
}
if {[$w cget -state] ne "disabled"} {
set Priv(buttonWindow) $w
$w configure -relief sunken
set Priv($w,prelief) sunken
# If this button has a repeatdelay set up, get it going with an after
after cancel $Priv(afterId)
set delay [$w cget -repeatdelay]
set Priv(repeated) 0
if {$delay > 0} {
set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
}
}
}
# ::tk::ButtonUp --
# The procedure below is invoked when the mouse button is released
# in a button widget. It restores the button's relief and invokes
# the command as long as the mouse hasn't left the button.
#
# Arguments:
# w - The name of the widget.
proc ::tk::ButtonUp w {
variable ::tk::Priv
if {[string equal $w $Priv(buttonWindow)]} {
set Priv(buttonWindow) ""
# Restore the button's relief if it was cached.
if {[info exists Priv($w,relief)]} {
if {[info exists Priv($w,prelief)] && \
$Priv($w,prelief) eq [$w cget -relief]} {
$w configure -relief $Priv($w,relief)
}
unset -nocomplain Priv($w,relief) Priv($w,prelief)
}
# Clean up the after event from the auto-repeater
after cancel $Priv(afterId)
if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} {
# Only invoke the command if it wasn't already invoked by the
# auto-repeater functionality
if { $Priv(repeated) == 0 } {
uplevel #0 [list $w invoke]
}
}
}
}
}
if {[string equal [tk windowingsystem] "classic"]
|| [string equal [tk windowingsystem] "aqua"]} {
####################
# Mac implementation
####################
# ::tk::ButtonEnter --
# The procedure below is invoked when the mouse pointer enters a
# button widget. It records the button we're in and changes the
# state of the button to active unless the button is disabled.
#
# Arguments:
# w - The name of the widget.
proc ::tk::ButtonEnter {w} {
variable ::tk::Priv
if {[$w cget -state] ne "disabled"} {
# If there's an -overrelief value, set the relief to that.
if {$Priv(buttonWindow) eq $w} {
$w configure -state active
} elseif {[set over [$w cget -overrelief]] ne ""} {
set Priv($w,relief) [$w cget -relief]
set Priv($w,prelief) $over
$w configure -relief $over
}
}
set Priv(window) $w
}
# ::tk::ButtonLeave --
# The procedure below is invoked when the mouse pointer leaves a
# button widget. It changes the state of the button back to
# inactive. If we're leaving the button window with a mouse button
# pressed (Priv(buttonWindow) == $w), restore the relief of the
# button too.
#
# Arguments:
# w - The name of the widget.
proc ::tk::ButtonLeave w {
variable ::tk::Priv
if {$w eq $Priv(buttonWindow)} {
$w configure -state normal
}
# Restore the original button relief if it was changed by Tk.
# That is signaled by the existence of Priv($w,prelief).
if {[info exists Priv($w,relief)]} {
if {[info exists Priv($w,prelief)] && \
$Priv($w,prelief) eq [$w cget -relief]} {
$w configure -relief $Priv($w,relief)
}
unset -nocomplain Priv($w,relief) Priv($w,prelief)
}
set Priv(window) ""
}
# ::tk::ButtonDown --
# The procedure below is invoked when the mouse button is pressed in
# a button widget. It records the fact that the mouse is in the button,
# saves the button's relief so it can be restored later, and changes
# the relief to sunken.
#
# Arguments:
# w - The name of the widget.
proc ::tk::ButtonDown w {
variable ::tk::Priv
if {[$w cget -state] ne "disabled"} {
set Priv(buttonWindow) $w
$w configure -state active
# If this button has a repeatdelay set up, get it going with an after
after cancel $Priv(afterId)
set Priv(repeated) 0
if { ![catch {$w cget -repeatdelay} delay] } {
if {$delay > 0} {
set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
}
}
}
}
# ::tk::ButtonUp --
# The procedure below is invoked when the mouse button is released
# in a button widget. It restores the button's relief and invokes
# the command as long as the mouse hasn't left the button.
#
# Arguments:
# w - The name of the widget.
proc ::tk::ButtonUp w {
variable ::tk::Priv
if {$Priv(buttonWindow) eq $w} {
set Priv(buttonWindow) ""
$w configure -state normal
# Restore the button's relief if it was cached.
if {[info exists Priv($w,relief)]} {
if {[info exists Priv($w,prelief)] && \
$Priv($w,prelief) eq [$w cget -relief]} {
$w configure -relief $Priv($w,relief)
}
unset -nocomplain Priv($w,relief) Priv($w,prelief)
}
# Clean up the after event from the auto-repeater
after cancel $Priv(afterId)
if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} {
# Only invoke the command if it wasn't already invoked by the
# auto-repeater functionality
if { $Priv(repeated) == 0 } {
uplevel #0 [list $w invoke]
}
}
}
}
}
##################
# Shared routines
##################
# ::tk::ButtonInvoke --
# The procedure below is called when a button is invoked through
# the keyboard. It simulate a press of the button via the mouse.
#
# Arguments:
# w - The name of the widget.
proc ::tk::ButtonInvoke w {
if {[$w cget -state] ne "disabled"} {
set oldRelief [$w cget -relief]
set oldState [$w cget -state]
$w configure -state active -relief sunken
update idletasks
after 100
$w configure -state $oldState -relief $oldRelief
uplevel #0 [list $w invoke]
}
}
# ::tk::ButtonAutoInvoke --
#
# Invoke an auto-repeating button, and set it up to continue to repeat.
#
# Arguments:
# w button to invoke.
#
# Results:
# None.
#
# Side effects:
# May create an after event to call ::tk::ButtonAutoInvoke.
proc ::tk::ButtonAutoInvoke {w} {
variable ::tk::Priv
after cancel $Priv(afterId)
set delay [$w cget -repeatinterval]
if {$Priv(window) eq $w} {
incr Priv(repeated)
uplevel #0 [list $w invoke]
}
if {$delay > 0} {
set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
}
}
# ::tk::CheckRadioInvoke --
# The procedure below is invoked when the mouse button is pressed in
# a checkbutton or radiobutton widget, or when the widget is invoked
# through the keyboard. It invokes the widget if it
# isn't disabled.
#
# Arguments:
# w - The name of the widget.
# cmd - The subcommand to invoke (one of invoke, select, or deselect).
proc ::tk::CheckRadioInvoke {w {cmd invoke}} {
if {[$w cget -state] ne "disabled"} {
uplevel #0 [list $w $cmd]
}
}
gradint-build/PocketPC/Program Files/lib/tk8.4/choosedir.tcl deleted 100644 → 0
View file @ 14df51ec
# choosedir.tcl --
#
# Choose directory dialog implementation for Unix/Mac.
#
# Copyright (c) 1998-2000 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: choosedir.tcl,v 1.15 2002/07/22 21:25:39 mdejong Exp $
# Make sure the tk::dialog namespace, in which all dialogs should live, exists
namespace eval ::tk::dialog {}
namespace eval ::tk::dialog::file {}
# Make the chooseDir namespace inside the dialog namespace
namespace eval ::tk::dialog::file::chooseDir {
namespace import ::tk::msgcat::*
}
# ::tk::dialog::file::chooseDir:: --
#
# Implements the TK directory selection dialog.
#
# Arguments:
# args Options parsed by the procedure.
#
proc ::tk::dialog::file::chooseDir:: {args} {
variable ::tk::Priv
set dataName __tk_choosedir
upvar ::tk::dialog::file::$dataName data
::tk::dialog::file::chooseDir::Config $dataName $args
if {[string equal $data(-parent) .]} {
set w .$dataName
} else {
set w $data(-parent).$dataName
}
# (re)create the dialog box if necessary
#
if {![winfo exists $w]} {
::tk::dialog::file::Create $w TkChooseDir
} elseif {[string compare [winfo class $w] TkChooseDir]} {
destroy $w
::tk::dialog::file::Create $w TkChooseDir
} else {
set data(dirMenuBtn) $w.f1.menu
set data(dirMenu) $w.f1.menu.menu
set data(upBtn) $w.f1.up
set data(icons) $w.icons
set data(ent) $w.f2.ent
set data(okBtn) $w.f2.ok
set data(cancelBtn) $w.f3.cancel
}
# Dialog boxes should be transient with respect to their parent,
# so that they will always stay on top of their parent window. However,
# some window managers will create the window as withdrawn if the parent
# window is withdrawn or iconified. Combined with the grab we put on the
# window, this can hang the entire application. Therefore we only make
# the dialog transient if the parent is viewable.
if {[winfo viewable [winfo toplevel $data(-parent)]] } {
wm transient $w $data(-parent)
}
trace variable data(selectPath) w [list ::tk::dialog::file::SetPath $w]
$data(dirMenuBtn) configure \
-textvariable ::tk::dialog::file::${dataName}(selectPath)
set data(filter) "*"
set data(previousEntryText) ""
::tk::dialog::file::UpdateWhenIdle $w
# Withdraw the window, then update all the geometry information
# so we know how big it wants to be, then center the window in the
# display and de-iconify it.
::tk::PlaceWindow $w widget $data(-parent)
wm title $w $data(-title)
# Set a grab and claim the focus too.
::tk::SetFocusGrab $w $data(ent)
$data(ent) delete 0 end
$data(ent) insert 0 $data(selectPath)
$data(ent) selection range 0 end
$data(ent) icursor end
# Wait for the user to respond, then restore the focus and
# return the index of the selected button. Restore the focus
# before deleting the window, since otherwise the window manager
# may take the focus away so we can't redirect it. Finally,
# restore any grab that was in effect.
vwait ::tk::Priv(selectFilePath)
::tk::RestoreFocusGrab $w $data(ent) withdraw
# Cleanup traces on selectPath variable
#
foreach trace [trace vinfo data(selectPath)] {
trace vdelete data(selectPath) [lindex $trace 0] [lindex $trace 1]
}
$data(dirMenuBtn) configure -textvariable {}
# Return value to user
#
return $Priv(selectFilePath)
}
# ::tk::dialog::file::chooseDir::Config --
#
# Configures the Tk choosedir dialog according to the argument list
#
proc ::tk::dialog::file::chooseDir::Config {dataName argList} {
upvar ::tk::dialog::file::$dataName data
# 0: Delete all variable that were set on data(selectPath) the
# last time the file dialog is used. The traces may cause troubles
# if the dialog is now used with a different -parent option.
#
foreach trace [trace vinfo data(selectPath)] {
trace vdelete data(selectPath) [lindex $trace 0] [lindex $trace 1]
}
# 1: the configuration specs
#
set specs {
{-mustexist "" "" 0}
{-initialdir "" "" ""}
{-parent "" "" "."}
{-title "" "" ""}
}
# 2: default values depending on the type of the dialog
#
if {![info exists data(selectPath)]} {
# first time the dialog has been popped up
set data(selectPath) [pwd]
}
# 3: parse the arguments
#
tclParseConfigSpec ::tk::dialog::file::$dataName $specs "" $argList
if {$data(-title) == ""} {
set data(-title) "[mc "Choose Directory"]"
}
# Stub out the -multiple value for the dialog; it doesn't make sense for
# choose directory dialogs, but we have to have something there because we
# share so much code with the file dialogs.
set data(-multiple) 0
# 4: set the default directory and selection according to the -initial
# settings
#
if {$data(-initialdir) != ""} {
# Ensure that initialdir is an absolute path name.
if {[file isdirectory $data(-initialdir)]} {
set old [pwd]
cd $data(-initialdir)
set data(selectPath) [pwd]
cd $old
} else {
set data(selectPath) [pwd]
}
}
if {![winfo exists $data(-parent)]} {
error "bad window path name \"$data(-parent)\""
}
}
# Gets called when user presses Return in the "Selection" entry or presses OK.
#
proc ::tk::dialog::file::chooseDir::OkCmd {w} {
upvar ::tk::dialog::file::[winfo name $w] data
# This is the brains behind selecting non-existant directories. Here's
# the flowchart:
# 1. If the icon list has a selection, join it with the current dir,
# and return that value.
# 1a. If the icon list does not have a selection ...
# 2. If the entry is empty, do nothing.
# 3. If the entry contains an invalid directory, then...
# 3a. If the value is the same as last time through here, end dialog.
# 3b. If the value is different than last time, save it and return.
# 4. If entry contains a valid directory, then...
# 4a. If the value is the same as the current directory, end dialog.
# 4b. If the value is different from the current directory, change to
# that directory.
set selection [tk::IconList_Curselection $data(icons)]
if { [llength $selection] != 0 } {
set iconText [tk::IconList_Get $data(icons) [lindex $selection 0]]
set iconText [file join $data(selectPath) $iconText]
::tk::dialog::file::chooseDir::Done $w $iconText
} else {
set text [$data(ent) get]
if { [string equal $text ""] } {
return
}
set text [eval file join [file split [string trim $text]]]
if { ![file exists $text] || ![file isdirectory $text] } {
# Entry contains an invalid directory. If it's the same as the
# last time they came through here, reset the saved value and end
# the dialog. Otherwise, save the value (so we can do this test
# next time).
if { [string equal $text $data(previousEntryText)] } {
set data(previousEntryText) ""
::tk::dialog::file::chooseDir::Done $w $text
} else {
set data(previousEntryText) $text
}
} else {
# Entry contains a valid directory. If it is the same as the
# current directory, end the dialog. Otherwise, change to that
# directory.
if { [string equal $text $data(selectPath)] } {
::tk::dialog::file::chooseDir::Done $w $text
} else {
set data(selectPath) $text
}
}
}
return
}
proc ::tk::dialog::file::chooseDir::DblClick {w} {
upvar ::tk::dialog::file::[winfo name $w] data
set selection [tk::IconList_Curselection $data(icons)]
if { [llength $selection] != 0 } {
set filenameFragment \
[tk::IconList_Get $data(icons) [lindex $selection 0]]
set file $data(selectPath)
if {[file isdirectory $file]} {
::tk::dialog::file::ListInvoke $w [list $filenameFragment]
return
}
}
}
# Gets called when user browses the IconList widget (dragging mouse, arrow
# keys, etc)
#
proc ::tk::dialog::file::chooseDir::ListBrowse {w text} {
upvar ::tk::dialog::file::[winfo name $w] data
if {[string equal $text ""]} {
return
}
set file [::tk::dialog::file::JoinFile $data(selectPath) $text]
$data(ent) delete 0 end
$data(ent) insert 0 $file
}
# ::tk::dialog::file::chooseDir::Done --
#
# Gets called when user has input a valid filename. Pops up a
# dialog box to confirm selection when necessary. Sets the
# Priv(selectFilePath) variable, which will break the "vwait"
# loop in tk_chooseDirectory and return the selected filename to the
# script that calls tk_getOpenFile or tk_getSaveFile
#
proc ::tk::dialog::file::chooseDir::Done {w {selectFilePath ""}} {
upvar ::tk::dialog::file::[winfo name $w] data
variable ::tk::Priv
if {[string equal $selectFilePath ""]} {
set selectFilePath $data(selectPath)
}
if { $data(-mustexist) } {
if { ![file exists $selectFilePath] || \
![file isdir $selectFilePath] } {
return
}
}
set Priv(selectFilePath) $selectFilePath
}
gradint-build/PocketPC/Program Files/lib/tk8.4/clrpick.tcl deleted 100644 → 0
View file @ 14df51ec
# clrpick.tcl --
#
# Color selection dialog for platforms that do not support a
# standard color selection dialog.
#
# RCS: @(#) $Id: clrpick.tcl,v 1.20 2003/02/21 14:40:26 dkf Exp $
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# ToDo:
#
# (1): Find out how many free colors are left in the colormap and
# don't allocate too many colors.
# (2): Implement HSV color selection.
#
# Make sure namespaces exist
namespace eval ::tk {}
namespace eval ::tk::dialog {}
namespace eval ::tk::dialog::color {
namespace import ::tk::msgcat::*
}
# ::tk::dialog::color:: --
#
# Create a color dialog and let the user choose a color. This function
# should not be called directly. It is called by the tk_chooseColor
# function when a native color selector widget does not exist
#
proc ::tk::dialog::color:: {args} {
variable ::tk::Priv
set dataName __tk__color
upvar ::tk::dialog::color::$dataName data
set w .$dataName
# The lines variables track the start and end indices of the line
# elements in the colorbar canvases.
set data(lines,red,start) 0
set data(lines,red,last) -1
set data(lines,green,start) 0
set data(lines,green,last) -1
set data(lines,blue,start) 0
set data(lines,blue,last) -1
# This is the actual number of lines that are drawn in each color strip.
# Note that the bars may be of any width.
# However, NUM_COLORBARS must be a number that evenly divides 256.
# Such as 256, 128, 64, etc.
set data(NUM_COLORBARS) 16
# BARS_WIDTH is the number of pixels wide the color bar portion of the
# canvas is. This number must be a multiple of NUM_COLORBARS
set data(BARS_WIDTH) 160
# PLGN_WIDTH is the number of pixels wide of the triangular selection
# polygon. This also results in the definition of the padding on the
# left and right sides which is half of PLGN_WIDTH. Make this number even.
set data(PLGN_HEIGHT) 10
# PLGN_HEIGHT is the height of the selection polygon and the height of the
# selection rectangle at the bottom of the color bar. No restrictions.
set data(PLGN_WIDTH) 10
Config $dataName $args
InitValues $dataName
set sc [winfo screen $data(-parent)]
set winExists [winfo exists $w]
if {!$winExists || [string compare $sc [winfo screen $w]]} {
if {$winExists} {
destroy $w
}
toplevel $w -class TkColorDialog -screen $sc
BuildDialog $w
}
# Dialog boxes should be transient with respect to their parent,
# so that they will always stay on top of their parent window. However,
# some window managers will create the window as withdrawn if the parent
# window is withdrawn or iconified. Combined with the grab we put on the
# window, this can hang the entire application. Therefore we only make
# the dialog transient if the parent is viewable.
if {[winfo viewable [winfo toplevel $data(-parent)]] } {
wm transient $w $data(-parent)
}
# 5. Withdraw the window, then update all the geometry information
# so we know how big it wants to be, then center the window in the
# display and de-iconify it.
::tk::PlaceWindow $w widget $data(-parent)
wm title $w $data(-title)
# 6. Set a grab and claim the focus too.
::tk::SetFocusGrab $w $data(okBtn)
# 7. Wait for the user to respond, then restore the focus and
# return the index of the selected button. Restore the focus
# before deleting the window, since otherwise the window manager
# may take the focus away so we can't redirect it. Finally,
# restore any grab that was in effect.
vwait ::tk::Priv(selectColor)
::tk::RestoreFocusGrab $w $data(okBtn)
unset data
return $Priv(selectColor)
}
# ::tk::dialog::color::InitValues --
#
# Get called during initialization or when user resets NUM_COLORBARS
#
proc ::tk::dialog::color::InitValues {dataName} {
upvar ::tk::dialog::color::$dataName data
# IntensityIncr is the difference in color intensity between a colorbar
# and its neighbors.
set data(intensityIncr) [expr {256 / $data(NUM_COLORBARS)}]
# ColorbarWidth is the width of each colorbar
set data(colorbarWidth) \
[expr {$data(BARS_WIDTH) / $data(NUM_COLORBARS)}]
# Indent is the width of the space at the left and right side of the
# colorbar. It is always half the selector polygon width, because the
# polygon extends into the space.
set data(indent) [expr {$data(PLGN_WIDTH) / 2}]
set data(colorPad) 2
set data(selPad) [expr {$data(PLGN_WIDTH) / 2}]
#
# minX is the x coordinate of the first colorbar
#
set data(minX) $data(indent)
#
# maxX is the x coordinate of the last colorbar
#
set data(maxX) [expr {$data(BARS_WIDTH) + $data(indent)-1}]
#
# canvasWidth is the width of the entire canvas, including the indents
#
set data(canvasWidth) [expr {$data(BARS_WIDTH) + $data(PLGN_WIDTH)}]
# Set the initial color, specified by -initialcolor, or the
# color chosen by the user the last time.
set data(selection) $data(-initialcolor)
set data(finalColor) $data(-initialcolor)
set rgb [winfo rgb . $data(selection)]
set data(red,intensity) [expr {[lindex $rgb 0]/0x100}]
set data(green,intensity) [expr {[lindex $rgb 1]/0x100}]
set data(blue,intensity) [expr {[lindex $rgb 2]/0x100}]
}
# ::tk::dialog::color::Config --
#
# Parses the command line arguments to tk_chooseColor
#
proc ::tk::dialog::color::Config {dataName argList} {
variable ::tk::Priv
upvar ::tk::dialog::color::$dataName data
# 1: the configuration specs
#
if {[info exists Priv(selectColor)] && \
[string compare $Priv(selectColor) ""]} {
set defaultColor $Priv(selectColor)
} else {
set defaultColor [. cget -background]
}
set specs [list \
[list -initialcolor "" "" $defaultColor] \
[list -parent "" "" "."] \
[list -title "" "" [mc "Color"]] \
]
# 2: parse the arguments
#
tclParseConfigSpec ::tk::dialog::color::$dataName $specs "" $argList
if {[string equal $data(-title) ""]} {
set data(-title) " "
}
if {[catch {winfo rgb . $data(-initialcolor)} err]} {
error $err
}
if {![winfo exists $data(-parent)]} {
error "bad window path name \"$data(-parent)\""
}
}
# ::tk::dialog::color::BuildDialog --
#
# Build the dialog.
#
proc ::tk::dialog::color::BuildDialog {w} {
upvar ::tk::dialog::color::[winfo name $w] data
# TopFrame contains the color strips and the color selection
#
set topFrame [frame $w.top -relief raised -bd 1]
# StripsFrame contains the colorstrips and the individual RGB entries
set stripsFrame [frame $topFrame.colorStrip]
set maxWidth [::tk::mcmaxamp &Red &Green &Blue]
set maxWidth [expr {$maxWidth<6?6:$maxWidth}]
set colorList [list \
red [mc "&Red"] \
green [mc "&Green"] \
blue [mc "&Blue"] \
]
foreach {color l} $colorList {
# each f frame contains an [R|G|B] entry and the equiv. color strip.
set f [frame $stripsFrame.$color]
# The box frame contains the label and entry widget for an [R|G|B]
set box [frame $f.box]
bind [::tk::AmpWidget label $box.label -text $l: -width $maxWidth \
-anchor ne] <<AltUnderlined>> [list focus $box.entry]
entry $box.entry -textvariable \
::tk::dialog::color::[winfo name $w]($color,intensity) \
-width 4
pack $box.label -side left -fill y -padx 2 -pady 3
pack $box.entry -side left -anchor n -pady 0
pack $box -side left -fill both
set height [expr \
{[winfo reqheight $box.entry] - \
2*([$box.entry cget -highlightthickness] + [$box.entry cget -bd])}]
canvas $f.color -height $height\
-width $data(BARS_WIDTH) -relief sunken -bd 2
canvas $f.sel -height $data(PLGN_HEIGHT) \
-width $data(canvasWidth) -highlightthickness 0
pack $f.color -expand yes -fill both
pack $f.sel -expand yes -fill both
pack $f -side top -fill x -padx 0 -pady 2
set data($color,entry) $box.entry
set data($color,col) $f.color
set data($color,sel) $f.sel
bind $data($color,col) <Configure> \
[list tk::dialog::color::DrawColorScale $w $color 1]
bind $data($color,col) <Enter> \
[list tk::dialog::color::EnterColorBar $w $color]
bind $data($color,col) <Leave> \
[list tk::dialog::color::LeaveColorBar $w $color]
bind $data($color,sel) <Enter> \
[list tk::dialog::color::EnterColorBar $w $color]
bind $data($color,sel) <Leave> \
[list tk::dialog::color::LeaveColorBar $w $color]
bind $box.entry <Return> [list tk::dialog::color::HandleRGBEntry $w]
}
pack $stripsFrame -side left -fill both -padx 4 -pady 10
# The selFrame contains a frame that demonstrates the currently
# selected color
#
set selFrame [frame $topFrame.sel]
set lab [::tk::AmpWidget label $selFrame.lab -text [mc "&Selection:"] \
-anchor sw]
set ent [entry $selFrame.ent \
-textvariable ::tk::dialog::color::[winfo name $w](selection) \
-width 16]
set f1 [frame $selFrame.f1 -relief sunken -bd 2]
set data(finalCanvas) [frame $f1.demo -bd 0 -width 100 -height 70]
pack $lab $ent -side top -fill x -padx 4 -pady 2
pack $f1 -expand yes -anchor nw -fill both -padx 6 -pady 10
pack $data(finalCanvas) -expand yes -fill both
bind $ent <Return> [list tk::dialog::color::HandleSelEntry $w]
pack $selFrame -side left -fill none -anchor nw
pack $topFrame -side top -expand yes -fill both -anchor nw
# the botFrame frame contains the buttons
#
set botFrame [frame $w.bot -relief raised -bd 1]
::tk::AmpWidget button $botFrame.ok -text [mc "&OK"] \
-command [list tk::dialog::color::OkCmd $w]
::tk::AmpWidget button $botFrame.cancel -text [mc "&Cancel"] \
-command [list tk::dialog::color::CancelCmd $w]
set data(okBtn) $botFrame.ok
set data(cancelBtn) $botFrame.cancel
grid x $botFrame.ok x $botFrame.cancel x -sticky ew
grid configure $botFrame.ok $botFrame.cancel -padx 10 -pady 10
grid columnconfigure $botFrame {0 4} -weight 1 -uniform space
grid columnconfigure $botFrame {1 3} -weight 1 -uniform button
grid columnconfigure $botFrame 2 -weight 2 -uniform space
pack $botFrame -side bottom -fill x
# Accelerator bindings
bind $lab <<AltUnderlined>> [list focus $ent]
bind $w <KeyPress-Escape> [list tk::ButtonInvoke $data(cancelBtn)]
bind $w <Alt-Key> [list tk::AltKeyInDialog $w %A]
wm protocol $w WM_DELETE_WINDOW [list tk::dialog::color::CancelCmd $w]
}
# ::tk::dialog::color::SetRGBValue --
#
# Sets the current selection of the dialog box
#
proc ::tk::dialog::color::SetRGBValue {w color} {
upvar ::tk::dialog::color::[winfo name $w] data
set data(red,intensity) [lindex $color 0]
set data(green,intensity) [lindex $color 1]
set data(blue,intensity) [lindex $color 2]
RedrawColorBars $w all
# Now compute the new x value of each colorbars pointer polygon
foreach color [list red green blue ] {
set x [RgbToX $w $data($color,intensity)]
MoveSelector $w $data($color,sel) $color $x 0
}
}
# ::tk::dialog::color::XToRgb --
#
# Converts a screen coordinate to intensity
#
proc ::tk::dialog::color::XToRgb {w x} {
upvar ::tk::dialog::color::[winfo name $w] data
set x [expr {($x * $data(intensityIncr))/ $data(colorbarWidth)}]
if {$x > 255} { set x 255 }
return $x
}
# ::tk::dialog::color::RgbToX
#
# Converts an intensity to screen coordinate.
#
proc ::tk::dialog::color::RgbToX {w color} {
upvar ::tk::dialog::color::[winfo name $w] data
return [expr {($color * $data(colorbarWidth)/ $data(intensityIncr))}]
}
# ::tk::dialog::color::DrawColorScale --
#
# Draw color scale is called whenever the size of one of the color
# scale canvases is changed.
#
proc ::tk::dialog::color::DrawColorScale {w c {create 0}} {
upvar ::tk::dialog::color::[winfo name $w] data
# col: color bar canvas
# sel: selector canvas
set col $data($c,col)
set sel $data($c,sel)
# First handle the case that we are creating everything for the first time.
if {$create} {
# First remove all the lines that already exist.
if { $data(lines,$c,last) > $data(lines,$c,start)} {
for {set i $data(lines,$c,start)} \
{$i <= $data(lines,$c,last)} { incr i} {
$sel delete $i
}
}
# Delete the selector if it exists
if {[info exists data($c,index)]} {
$sel delete $data($c,index)
}
# Draw the selection polygons
CreateSelector $w $sel $c
$sel bind $data($c,index) <ButtonPress-1> \
[list tk::dialog::color::StartMove $w $sel $c %x $data(selPad) 1]
$sel bind $data($c,index) <B1-Motion> \
[list tk::dialog::color::MoveSelector $w $sel $c %x $data(selPad)]
$sel bind $data($c,index) <ButtonRelease-1> \
[list tk::dialog::color::ReleaseMouse $w $sel $c %x $data(selPad)]
set height [winfo height $col]
# Create an invisible region under the colorstrip to catch mouse clicks
# that aren't on the selector.
set data($c,clickRegion) [$sel create rectangle 0 0 \
$data(canvasWidth) $height -fill {} -outline {}]
bind $col <ButtonPress-1> \
[list tk::dialog::color::StartMove $w $sel $c %x $data(colorPad)]
bind $col <B1-Motion> \
[list tk::dialog::color::MoveSelector $w $sel $c %x $data(colorPad)]
bind $col <ButtonRelease-1> \
[list tk::dialog::color::ReleaseMouse $w $sel $c %x $data(colorPad)]
$sel bind $data($c,clickRegion) <ButtonPress-1> \
[list tk::dialog::color::StartMove $w $sel $c %x $data(selPad)]
$sel bind $data($c,clickRegion) <B1-Motion> \
[list tk::dialog::color::MoveSelector $w $sel $c %x $data(selPad)]
$sel bind $data($c,clickRegion) <ButtonRelease-1> \
[list tk::dialog::color::ReleaseMouse $w $sel $c %x $data(selPad)]
} else {
# l is the canvas index of the first colorbar.
set l $data(lines,$c,start)
}
# Draw the color bars.
set highlightW [expr {[$col cget -highlightthickness] + [$col cget -bd]}]
for {set i 0} { $i < $data(NUM_COLORBARS)} { incr i} {
set intensity [expr {$i * $data(intensityIncr)}]
set startx [expr {$i * $data(colorbarWidth) + $highlightW}]
if {[string equal $c "red"]} {
set color [format "#%02x%02x%02x" \
$intensity \
$data(green,intensity) \
$data(blue,intensity)]
} elseif {[string equal $c "green"]} {
set color [format "#%02x%02x%02x" \
$data(red,intensity) \
$intensity \
$data(blue,intensity)]
} else {
set color [format "#%02x%02x%02x" \
$data(red,intensity) \
$data(green,intensity) \
$intensity]
}
if {$create} {
set index [$col create rect $startx $highlightW \
[expr {$startx +$data(colorbarWidth)}] \
[expr {[winfo height $col] + $highlightW}]\
-fill $color -outline $color]
} else {
$col itemconfigure $l -fill $color -outline $color
incr l
}
}
$sel raise $data($c,index)
if {$create} {
set data(lines,$c,last) $index
set data(lines,$c,start) [expr {$index - $data(NUM_COLORBARS) + 1}]
}
RedrawFinalColor $w
}
# ::tk::dialog::color::CreateSelector --
#
# Creates and draws the selector polygon at the position
# $data($c,intensity).
#
proc ::tk::dialog::color::CreateSelector {w sel c } {
upvar ::tk::dialog::color::[winfo name $w] data
set data($c,index) [$sel create polygon \
0 $data(PLGN_HEIGHT) \
$data(PLGN_WIDTH) $data(PLGN_HEIGHT) \
$data(indent) 0]
set data($c,x) [RgbToX $w $data($c,intensity)]
$sel move $data($c,index) $data($c,x) 0
}
# ::tk::dialog::color::RedrawFinalColor
#
# Combines the intensities of the three colors into the final color
#
proc ::tk::dialog::color::RedrawFinalColor {w} {
upvar ::tk::dialog::color::[winfo name $w] data
set color [format "#%02x%02x%02x" $data(red,intensity) \
$data(green,intensity) $data(blue,intensity)]
$data(finalCanvas) configure -bg $color
set data(finalColor) $color
set data(selection) $color
set data(finalRGB) [list \
$data(red,intensity) \
$data(green,intensity) \
$data(blue,intensity)]
}
# ::tk::dialog::color::RedrawColorBars --
#
# Only redraws the colors on the color strips that were not manipulated.
# Params: color of colorstrip that changed. If color is not [red|green|blue]
# Then all colorstrips will be updated
#
proc ::tk::dialog::color::RedrawColorBars {w colorChanged} {
upvar ::tk::dialog::color::[winfo name $w] data
switch $colorChanged {
red {
DrawColorScale $w green
DrawColorScale $w blue
}
green {
DrawColorScale $w red
DrawColorScale $w blue
}
blue {
DrawColorScale $w red
DrawColorScale $w green
}
default {
DrawColorScale $w red
DrawColorScale $w green
DrawColorScale $w blue
}
}
RedrawFinalColor $w
}
#----------------------------------------------------------------------
# Event handlers
#----------------------------------------------------------------------
# ::tk::dialog::color::StartMove --
#
# Handles a mousedown button event over the selector polygon.
# Adds the bindings for moving the mouse while the button is
# pressed. Sets the binding for the button-release event.
#
# Params: sel is the selector canvas window, color is the color of the strip.
#
proc ::tk::dialog::color::StartMove {w sel color x delta {dontMove 0}} {
upvar ::tk::dialog::color::[winfo name $w] data
if {!$dontMove} {
MoveSelector $w $sel $color $x $delta
}
}
# ::tk::dialog::color::MoveSelector --
#
# Moves the polygon selector so that its middle point has the same
# x value as the specified x. If x is outside the bounds [0,255],
# the selector is set to the closest endpoint.
#
# Params: sel is the selector canvas, c is [red|green|blue]
# x is a x-coordinate.
#
proc ::tk::dialog::color::MoveSelector {w sel color x delta} {
upvar ::tk::dialog::color::[winfo name $w] data
incr x -$delta
if { $x < 0 } {
set x 0
} elseif { $x > $data(BARS_WIDTH)} {
set x $data(BARS_WIDTH)
}
set diff [expr {$x - $data($color,x)}]
$sel move $data($color,index) $diff 0
set data($color,x) [expr {$data($color,x) + $diff}]
# Return the x value that it was actually set at
return $x
}
# ::tk::dialog::color::ReleaseMouse
#
# Removes mouse tracking bindings, updates the colorbars.
#
# Params: sel is the selector canvas, color is the color of the strip,
# x is the x-coord of the mouse.
#
proc ::tk::dialog::color::ReleaseMouse {w sel color x delta} {
upvar ::tk::dialog::color::[winfo name $w] data
set x [MoveSelector $w $sel $color $x $delta]
# Determine exactly what color we are looking at.
set data($color,intensity) [XToRgb $w $x]
RedrawColorBars $w $color
}
# ::tk::dialog::color::ResizeColorbars --
#
# Completely redraws the colorbars, including resizing the
# colorstrips
#
proc ::tk::dialog::color::ResizeColorBars {w} {
upvar ::tk::dialog::color::[winfo name $w] data
if { ($data(BARS_WIDTH) < $data(NUM_COLORBARS)) ||
(($data(BARS_WIDTH) % $data(NUM_COLORBARS)) != 0)} {
set data(BARS_WIDTH) $data(NUM_COLORBARS)
}
InitValues [winfo name $w]
foreach color [list red green blue ] {
$data($color,col) configure -width $data(canvasWidth)
DrawColorScale $w $color 1
}
}
# ::tk::dialog::color::HandleSelEntry --
#
# Handles the return keypress event in the "Selection:" entry
#
proc ::tk::dialog::color::HandleSelEntry {w} {
upvar ::tk::dialog::color::[winfo name $w] data
set text [string trim $data(selection)]
# Check to make sure that the color is valid
if {[catch {set color [winfo rgb . $text]} ]} {
set data(selection) $data(finalColor)
return
}
set R [expr {[lindex $color 0]/0x100}]
set G [expr {[lindex $color 1]/0x100}]
set B [expr {[lindex $color 2]/0x100}]
SetRGBValue $w "$R $G $B"
set data(selection) $text
}
# ::tk::dialog::color::HandleRGBEntry --
#
# Handles the return keypress event in the R, G or B entry
#
proc ::tk::dialog::color::HandleRGBEntry {w} {
upvar ::tk::dialog::color::[winfo name $w] data
foreach c [list red green blue] {
if {[catch {
set data($c,intensity) [expr {int($data($c,intensity))}]
}]} {
set data($c,intensity) 0
}
if {$data($c,intensity) < 0} {
set data($c,intensity) 0
}
if {$data($c,intensity) > 255} {
set data($c,intensity) 255
}
}
SetRGBValue $w "$data(red,intensity) \
$data(green,intensity) $data(blue,intensity)"
}
# mouse cursor enters a color bar
#
proc ::tk::dialog::color::EnterColorBar {w color} {
upvar ::tk::dialog::color::[winfo name $w] data
$data($color,sel) itemconfig $data($color,index) -fill red
}
# mouse leaves enters a color bar
#
proc ::tk::dialog::color::LeaveColorBar {w color} {
upvar ::tk::dialog::color::[winfo name $w] data
$data($color,sel) itemconfig $data($color,index) -fill black
}
# user hits OK button
#
proc ::tk::dialog::color::OkCmd {w} {
variable ::tk::Priv
upvar ::tk::dialog::color::[winfo name $w] data
set Priv(selectColor) $data(finalColor)
}
# user hits Cancel button
#
proc ::tk::dialog::color::CancelCmd {w} {
variable ::tk::Priv
set Priv(selectColor) ""
}
gradint-build/PocketPC/Program Files/lib/tk8.4/comdlg.tcl deleted 100644 → 0
View file @ 14df51ec
# comdlg.tcl --
#
# Some functions needed for the common dialog boxes. Probably need to go
# in a different file.
#
# RCS: @(#) $Id: comdlg.tcl,v 1.9 2003/02/21 13:32:14 dkf Exp $
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# tclParseConfigSpec --
#
# Parses a list of "-option value" pairs. If all options and
# values are legal, the values are stored in
# $data($option). Otherwise an error message is returned. When
# an error happens, the data() array may have been partially
# modified, but all the modified members of the data(0 array are
# guaranteed to have valid values. This is different than
# Tk_ConfigureWidget() which does not modify the value of a
# widget record if any error occurs.
#
# Arguments:
#
# w = widget record to modify. Must be the pathname of a widget.
#
# specs = {
# {-commandlineswitch resourceName ResourceClass defaultValue verifier}
# {....}
# }
#
# flags = currently unused.
#
# argList = The list of "-option value" pairs.
#
proc tclParseConfigSpec {w specs flags argList} {
upvar #0 $w data
# 1: Put the specs in associative arrays for faster access
#
foreach spec $specs {
if {[llength $spec] < 4} {
error "\"spec\" should contain 5 or 4 elements"
}
set cmdsw [lindex $spec 0]
set cmd($cmdsw) ""
set rname($cmdsw) [lindex $spec 1]
set rclass($cmdsw) [lindex $spec 2]
set def($cmdsw) [lindex $spec 3]
set verproc($cmdsw) [lindex $spec 4]
}
if {[llength $argList] & 1} {
set cmdsw [lindex $argList end]
if {![info exists cmd($cmdsw)]} {
error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
}
error "value for \"$cmdsw\" missing"
}
# 2: set the default values
#
foreach cmdsw [array names cmd] {
set data($cmdsw) $def($cmdsw)
}
# 3: parse the argument list
#
foreach {cmdsw value} $argList {
if {![info exists cmd($cmdsw)]} {
error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
}
set data($cmdsw) $value
}
# Done!
}
proc tclListValidFlags {v} {
upvar $v cmd
set len [llength [array names cmd]]
set i 1
set separator ""
set errormsg ""
foreach cmdsw [lsort [array names cmd]] {
append errormsg "$separator$cmdsw"
incr i
if {$i == $len} {
set separator ", or "
} else {
set separator ", "
}
}
return $errormsg
}
#----------------------------------------------------------------------
#
# Focus Group
#
# Focus groups are used to handle the user's focusing actions inside a
# toplevel.
#
# One example of using focus groups is: when the user focuses on an
# entry, the text in the entry is highlighted and the cursor is put to
# the end of the text. When the user changes focus to another widget,
# the text in the previously focused entry is validated.
#
#----------------------------------------------------------------------
# ::tk::FocusGroup_Create --
#
# Create a focus group. All the widgets in a focus group must be
# within the same focus toplevel. Each toplevel can have only
# one focus group, which is identified by the name of the
# toplevel widget.
#
proc ::tk::FocusGroup_Create {t} {
variable ::tk::Priv
if {[string compare [winfo toplevel $t] $t]} {
error "$t is not a toplevel window"
}
if {![info exists Priv(fg,$t)]} {
set Priv(fg,$t) 1
set Priv(focus,$t) ""
bind $t <FocusIn> [list tk::FocusGroup_In $t %W %d]
bind $t <FocusOut> [list tk::FocusGroup_Out $t %W %d]
bind $t <Destroy> [list tk::FocusGroup_Destroy $t %W]
}
}
# ::tk::FocusGroup_BindIn --
#
# Add a widget into the "FocusIn" list of the focus group. The $cmd will be
# called when the widget is focused on by the user.
#
proc ::tk::FocusGroup_BindIn {t w cmd} {
variable FocusIn
variable ::tk::Priv
if {![info exists Priv(fg,$t)]} {
error "focus group \"$t\" doesn't exist"
}
set FocusIn($t,$w) $cmd
}
# ::tk::FocusGroup_BindOut --
#
# Add a widget into the "FocusOut" list of the focus group. The
# $cmd will be called when the widget loses the focus (User
# types Tab or click on another widget).
#
proc ::tk::FocusGroup_BindOut {t w cmd} {
variable FocusOut
variable ::tk::Priv
if {![info exists Priv(fg,$t)]} {
error "focus group \"$t\" doesn't exist"
}
set FocusOut($t,$w) $cmd
}
# ::tk::FocusGroup_Destroy --
#
# Cleans up when members of the focus group is deleted, or when the
# toplevel itself gets deleted.
#
proc ::tk::FocusGroup_Destroy {t w} {
variable FocusIn
variable FocusOut
variable ::tk::Priv
if {[string equal $t $w]} {
unset Priv(fg,$t)
unset Priv(focus,$t)
foreach name [array names FocusIn $t,*] {
unset FocusIn($name)
}
foreach name [array names FocusOut $t,*] {
unset FocusOut($name)
}
} else {
if {[info exists Priv(focus,$t)] && \
[string equal $Priv(focus,$t) $w]} {
set Priv(focus,$t) ""
}
catch {
unset FocusIn($t,$w)
}
catch {
unset FocusOut($t,$w)
}
}
}
# ::tk::FocusGroup_In --
#
# Handles the <FocusIn> event. Calls the FocusIn command for the newly
# focused widget in the focus group.
#
proc ::tk::FocusGroup_In {t w detail} {
variable FocusIn
variable ::tk::Priv
if {[string compare $detail NotifyNonlinear] && \
[string compare $detail NotifyNonlinearVirtual]} {
# This is caused by mouse moving out&in of the window *or*
# ordinary keypresses some window managers (ie: CDE [Bug: 2960]).
return
}
if {![info exists FocusIn($t,$w)]} {
set FocusIn($t,$w) ""
return
}
if {![info exists Priv(focus,$t)]} {
return
}
if {[string equal $Priv(focus,$t) $w]} {
# This is already in focus
#
return
} else {
set Priv(focus,$t) $w
eval $FocusIn($t,$w)
}
}
# ::tk::FocusGroup_Out --
#
# Handles the <FocusOut> event. Checks if this is really a lose
# focus event, not one generated by the mouse moving out of the
# toplevel window. Calls the FocusOut command for the widget
# who loses its focus.
#
proc ::tk::FocusGroup_Out {t w detail} {
variable FocusOut
variable ::tk::Priv
if {[string compare $detail NotifyNonlinear] && \
[string compare $detail NotifyNonlinearVirtual]} {
# This is caused by mouse moving out of the window
return
}
if {![info exists Priv(focus,$t)]} {
return
}
if {![info exists FocusOut($t,$w)]} {
return
} else {
eval $FocusOut($t,$w)
set Priv(focus,$t) ""
}
}
# ::tk::FDGetFileTypes --
#
# Process the string given by the -filetypes option of the file
# dialogs. Similar to the C function TkGetFileFilters() on the Mac
# and Windows platform.
#
proc ::tk::FDGetFileTypes {string} {
foreach t $string {
if {[llength $t] < 2 || [llength $t] > 3} {
error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""
}
eval lappend [list fileTypes([lindex $t 0])] [lindex $t 1]
}
set types {}
foreach t $string {
set label [lindex $t 0]
set exts {}
if {[info exists hasDoneType($label)]} {
continue
}
set name "$label ("
set sep ""
set doAppend 1
foreach ext $fileTypes($label) {
if {[string equal $ext ""]} {
continue
}
regsub {^[.]} $ext "*." ext
if {![info exists hasGotExt($label,$ext)]} {
if {$doAppend} {
if {[string length $sep] && [string length $name]>40} {
set doAppend 0
append name $sep...
} else {
append name $sep$ext
}
}
lappend exts $ext
set hasGotExt($label,$ext) 1
}
set sep ,
}
append name ")"
lappend types [list $name $exts]
set hasDoneType($label) 1
}
return $types
}
gradint-build/PocketPC/Program Files/lib/tk8.4/console.tcl deleted 100644 → 0
View file @ 14df51ec
# console.tcl --
#
# This code constructs the console window for an application. It
# can be used by non-unix systems that do not have built-in support
# for shells.
#
# RCS: @(#) $Id: console.tcl,v 1.22 2003/02/21 03:34:29 das Exp $
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# TODO: history - remember partially written command
namespace eval ::tk::console {
variable blinkTime 500 ; # msecs to blink braced range for
variable blinkRange 1 ; # enable blinking of the entire braced range
variable magicKeys 1 ; # enable brace matching and proc/var recognition
variable maxLines 600 ; # maximum # of lines buffered in console
variable showMatches 1 ; # show multiple expand matches
variable inPlugin [info exists embed_args]
variable defaultPrompt ; # default prompt if tcl_prompt1 isn't used
if {$inPlugin} {
set defaultPrompt {subst {[history nextid] % }}
} else {
set defaultPrompt {subst {([file tail [pwd]]) [history nextid] % }}
}
}
# simple compat function for tkcon code added for this console
interp alias {} EvalAttached {} consoleinterp eval
# ::tk::ConsoleInit --
# This procedure constructs and configures the console windows.
#
# Arguments:
# None.
proc ::tk::ConsoleInit {} {
global tcl_platform
if {![consoleinterp eval {set tcl_interactive}]} {
wm withdraw .
}
if {[string equal $tcl_platform(platform) "macintosh"]
|| [string equal [tk windowingsystem] "aqua"]} {
set mod "Cmd"
} else {
set mod "Ctrl"
}
if {[catch {menu .menubar} err]} { bgerror "INIT: $err" }
.menubar add cascade -label File -menu .menubar.file -underline 0
.menubar add cascade -label Edit -menu .menubar.edit -underline 0
menu .menubar.file -tearoff 0
.menubar.file add command -label [mc "Source..."] \
-underline 0 -command tk::ConsoleSource
.menubar.file add command -label [mc "Hide Console"] \
-underline 0 -command {wm withdraw .}
.menubar.file add command -label [mc "Clear Console"] \
-underline 0 -command {.console delete 1.0 "promptEnd linestart"}
if {[string equal $tcl_platform(platform) "macintosh"]
|| [string equal [tk windowingsystem] "aqua"]} {
.menubar.file add command -label [mc "Quit"] \
-command exit -accel Cmd-Q
} else {
.menubar.file add command -label [mc "Exit"] \
-underline 1 -command exit
}
menu .menubar.edit -tearoff 0
.menubar.edit add command -label [mc "Cut"] -underline 2 \
-command { event generate .console <<Cut>> } -accel "$mod+X"
.menubar.edit add command -label [mc "Copy"] -underline 0 \
-command { event generate .console <<Copy>> } -accel "$mod+C"
.menubar.edit add command -label [mc "Paste"] -underline 1 \
-command { event generate .console <<Paste>> } -accel "$mod+V"
if {[string compare $tcl_platform(platform) "windows"]} {
.menubar.edit add command -label [mc "Clear"] -underline 2 \
-command { event generate .console <<Clear>> }
} else {
.menubar.edit add command -label [mc "Delete"] -underline 0 \
-command { event generate .console <<Clear>> } -accel "Del"
.menubar add cascade -label Help -menu .menubar.help -underline 0
menu .menubar.help -tearoff 0
.menubar.help add command -label [mc "About..."] \
-underline 0 -command tk::ConsoleAbout
}
. configure -menu .menubar
set con [text .console -yscrollcommand [list .sb set] -setgrid true]
scrollbar .sb -command [list $con yview]
pack .sb -side right -fill both
pack $con -fill both -expand 1 -side left
switch -exact $tcl_platform(platform) {
"macintosh" {
$con configure -font {Monaco 9 normal} -highlightthickness 0
}
"windows" {
$con configure -font systemfixed
}
"unix" {
if {[string equal [tk windowingsystem] "aqua"]} {
$con configure -font {Monaco 9 normal} -highlightthickness 0
}
}
}
ConsoleBind $con
$con tag configure stderr -foreground red
$con tag configure stdin -foreground blue
$con tag configure prompt -foreground \#8F4433
$con tag configure proc -foreground \#008800
$con tag configure var -background \#FFC0D0
$con tag raise sel
$con tag configure blink -background \#FFFF00
$con tag configure find -background \#FFFF00
focus $con
wm protocol . WM_DELETE_WINDOW { wm withdraw . }
wm title . [mc "Console"]
flush stdout
$con mark set output [$con index "end - 1 char"]
tk::TextSetCursor $con end
$con mark set promptEnd insert
$con mark gravity promptEnd left
}
# ::tk::ConsoleSource --
#
# Prompts the user for a file to source in the main interpreter.
#
# Arguments:
# None.
proc ::tk::ConsoleSource {} {
set filename [tk_getOpenFile -defaultextension .tcl -parent . \
-title [mc "Select a file to source"] \
-filetypes [list \
[list [mc "Tcl Scripts"] .tcl] \
[list [mc "All Files"] *]]]
if {[string compare $filename ""]} {
set cmd [list source $filename]
if {[catch {consoleinterp eval $cmd} result]} {
ConsoleOutput stderr "$result\n"
}
}
}
# ::tk::ConsoleInvoke --
# Processes the command line input. If the command is complete it
# is evaled in the main interpreter. Otherwise, the continuation
# prompt is added and more input may be added.
#
# Arguments:
# None.
proc ::tk::ConsoleInvoke {args} {
set ranges [.console tag ranges input]
set cmd ""
if {[llength $ranges]} {
set pos 0
while {[string compare [lindex $ranges $pos] ""]} {
set start [lindex $ranges $pos]
set end [lindex $ranges [incr pos]]
append cmd [.console get $start $end]
incr pos
}
}
if {[string equal $cmd ""]} {
ConsolePrompt
} elseif {[info complete $cmd]} {
.console mark set output end
.console tag delete input
set result [consoleinterp record $cmd]
if {[string compare $result ""]} {
puts $result
}
ConsoleHistory reset
ConsolePrompt
} else {
ConsolePrompt partial
}
.console yview -pickplace insert
}
# ::tk::ConsoleHistory --
# This procedure implements command line history for the
# console. In general is evals the history command in the
# main interpreter to obtain the history. The variable
# ::tk::HistNum is used to store the current location in the history.
#
# Arguments:
# cmd - Which action to take: prev, next, reset.
set ::tk::HistNum 1
proc ::tk::ConsoleHistory {cmd} {
variable HistNum
switch $cmd {
prev {
incr HistNum -1
if {$HistNum == 0} {
set cmd {history event [expr {[history nextid] -1}]}
} else {
set cmd "history event $HistNum"
}
if {[catch {consoleinterp eval $cmd} cmd]} {
incr HistNum
return
}
.console delete promptEnd end
.console insert promptEnd $cmd {input stdin}
}
next {
incr HistNum
if {$HistNum == 0} {
set cmd {history event [expr {[history nextid] -1}]}
} elseif {$HistNum > 0} {
set cmd ""
set HistNum 1
} else {
set cmd "history event $HistNum"
}
if {[string compare $cmd ""]} {
catch {consoleinterp eval $cmd} cmd
}
.console delete promptEnd end
.console insert promptEnd $cmd {input stdin}
}
reset {
set HistNum 1
}
}
}
# ::tk::ConsolePrompt --
# This procedure draws the prompt. If tcl_prompt1 or tcl_prompt2
# exists in the main interpreter it will be called to generate the
# prompt. Otherwise, a hard coded default prompt is printed.
#
# Arguments:
# partial - Flag to specify which prompt to print.
proc ::tk::ConsolePrompt {{partial normal}} {
set w .console
if {[string equal $partial "normal"]} {
set temp [$w index "end - 1 char"]
$w mark set output end
if {[consoleinterp eval "info exists tcl_prompt1"]} {
consoleinterp eval "eval \[set tcl_prompt1\]"
} else {
puts -nonewline [EvalAttached $::tk::console::defaultPrompt]
}
} else {
set temp [$w index output]
$w mark set output end
if {[consoleinterp eval "info exists tcl_prompt2"]} {
consoleinterp eval "eval \[set tcl_prompt2\]"
} else {
puts -nonewline "> "
}
}
flush stdout
$w mark set output $temp
::tk::TextSetCursor $w end
$w mark set promptEnd insert
$w mark gravity promptEnd left
::tk::console::ConstrainBuffer $w $::tk::console::maxLines
$w see end
}
# ::tk::ConsoleBind --
# This procedure first ensures that the default bindings for the Text
# class have been defined. Then certain bindings are overridden for
# the class.
#
# Arguments:
# None.
proc ::tk::ConsoleBind {w} {
bindtags $w [list $w Console PostConsole [winfo toplevel $w] all]
## Get all Text bindings into Console
foreach ev [bind Text] { bind Console $ev [bind Text $ev] }
## We really didn't want the newline insertion...
bind Console <Control-Key-o> {}
## ...or any Control-v binding (would block <<Paste>>)
bind Console <Control-Key-v> {}
# For the moment, transpose isn't enabled until the console
# gets and overhaul of how it handles input -- hobbs
bind Console <Control-Key-t> {}
# Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
# Otherwise, if a widget binding for one of these is defined, the
bind Console <Alt-KeyPress> {# nothing }
bind Console <Meta-KeyPress> {# nothing}
bind Console <Control-KeyPress> {# nothing}
foreach {ev key} {
<<Console_Prev>> <Key-Up>
<<Console_Next>> <Key-Down>
<<Console_NextImmediate>> <Control-Key-n>
<<Console_PrevImmediate>> <Control-Key-p>
<<Console_PrevSearch>> <Control-Key-r>
<<Console_NextSearch>> <Control-Key-s>
<<Console_Expand>> <Key-Tab>
<<Console_Expand>> <Key-Escape>
<<Console_ExpandFile>> <Control-Shift-Key-F>
<<Console_ExpandProc>> <Control-Shift-Key-P>
<<Console_ExpandVar>> <Control-Shift-Key-V>
<<Console_Tab>> <Control-Key-i>
<<Console_Tab>> <Meta-Key-i>
<<Console_Eval>> <Key-Return>
<<Console_Eval>> <Key-KP_Enter>
<<Console_Clear>> <Control-Key-l>
<<Console_KillLine>> <Control-Key-k>
<<Console_Transpose>> <Control-Key-t>
<<Console_ClearLine>> <Control-Key-u>
<<Console_SaveCommand>> <Control-Key-z>
} {
event add $ev $key
bind Console $key {}
}
bind Console <<Console_Expand>> {
if {[%W compare insert > promptEnd]} {::tk::console::Expand %W}
}
bind Console <<Console_ExpandFile>> {
if {[%W compare insert > promptEnd]} {::tk::console::Expand %W path}
}
bind Console <<Console_ExpandProc>> {
if {[%W compare insert > promptEnd]} {::tk::console::Expand %W proc}
}
bind Console <<Console_ExpandVar>> {
if {[%W compare insert > promptEnd]} {::tk::console::Expand %W var}
}
bind Console <<Console_Eval>> {
%W mark set insert {end - 1c}
tk::ConsoleInsert %W "\n"
tk::ConsoleInvoke
break
}
bind Console <Delete> {
if {[string compare {} [%W tag nextrange sel 1.0 end]] \
&& [%W compare sel.first >= promptEnd]} {
%W delete sel.first sel.last
} elseif {[%W compare insert >= promptEnd]} {
%W delete insert
%W see insert
}
}
bind Console <BackSpace> {
if {[string compare {} [%W tag nextrange sel 1.0 end]] \
&& [%W compare sel.first >= promptEnd]} {
%W delete sel.first sel.last
} elseif {[%W compare insert != 1.0] && \
[%W compare insert > promptEnd]} {
%W delete insert-1c
%W see insert
}
}
bind Console <Control-h> [bind Console <BackSpace>]
bind Console <Home> {
if {[%W compare insert < promptEnd]} {
tk::TextSetCursor %W {insert linestart}
} else {
tk::TextSetCursor %W promptEnd
}
}
bind Console <Control-a> [bind Console <Home>]
bind Console <End> {
tk::TextSetCursor %W {insert lineend}
}
bind Console <Control-e> [bind Console <End>]
bind Console <Control-d> {
if {[%W compare insert < promptEnd]} break
%W delete insert
}
bind Console <<Console_KillLine>> {
if {[%W compare insert < promptEnd]} break
if {[%W compare insert == {insert lineend}]} {
%W delete insert
} else {
%W delete insert {insert lineend}
}
}
bind Console <<Console_Clear>> {
## Clear console display
%W delete 1.0 "promptEnd linestart"
}
bind Console <<Console_ClearLine>> {
## Clear command line (Unix shell staple)
%W delete promptEnd end
}
bind Console <Meta-d> {
if {[%W compare insert >= promptEnd]} {
%W delete insert {insert wordend}
}
}
bind Console <Meta-BackSpace> {
if {[%W compare {insert -1c wordstart} >= promptEnd]} {
%W delete {insert -1c wordstart} insert
}
}
bind Console <Meta-d> {
if {[%W compare insert >= promptEnd]} {
%W delete insert {insert wordend}
}
}
bind Console <Meta-BackSpace> {
if {[%W compare {insert -1c wordstart} >= promptEnd]} {
%W delete {insert -1c wordstart} insert
}
}
bind Console <Meta-Delete> {
if {[%W compare insert >= promptEnd]} {
%W delete insert {insert wordend}
}
}
bind Console <<Console_Prev>> {
tk::ConsoleHistory prev
}
bind Console <<Console_Next>> {
tk::ConsoleHistory next
}
bind Console <Insert> {
catch {tk::ConsoleInsert %W [::tk::GetSelection %W PRIMARY]}
}
bind Console <KeyPress> {
tk::ConsoleInsert %W %A
}
bind Console <F9> {
eval destroy [winfo child .]
if {[string equal $tcl_platform(platform) "macintosh"]} {
if {[catch {source [file join $tk_library console.tcl]}]} {source -rsrc console}
} else {
source [file join $tk_library console.tcl]
}
}
if {[string equal $::tcl_platform(platform) "macintosh"]
|| [string equal [tk windowingsystem] "aqua"]} {
bind Console <Command-q> {
exit
}
}
bind Console <<Cut>> {
# Same as the copy event
if {![catch {set data [%W get sel.first sel.last]}]} {
clipboard clear -displayof %W
clipboard append -displayof %W $data
}
}
bind Console <<Copy>> {
if {![catch {set data [%W get sel.first sel.last]}]} {
clipboard clear -displayof %W
clipboard append -displayof %W $data
}
}
bind Console <<Paste>> {
catch {
set clip [::tk::GetSelection %W CLIPBOARD]
set list [split $clip \n\r]
tk::ConsoleInsert %W [lindex $list 0]
foreach x [lrange $list 1 end] {
%W mark set insert {end - 1c}
tk::ConsoleInsert %W "\n"
tk::ConsoleInvoke
tk::ConsoleInsert %W $x
}
}
}
##
## Bindings for doing special things based on certain keys
##
bind PostConsole <Key-parenright> {
if {[string compare \\ [%W get insert-2c]]} {
::tk::console::MatchPair %W \( \) promptEnd
}
}
bind PostConsole <Key-bracketright> {
if {[string compare \\ [%W get insert-2c]]} {
::tk::console::MatchPair %W \[ \] promptEnd
}
}
bind PostConsole <Key-braceright> {
if {[string compare \\ [%W get insert-2c]]} {
::tk::console::MatchPair %W \{ \} promptEnd
}
}
bind PostConsole <Key-quotedbl> {
if {[string compare \\ [%W get insert-2c]]} {
::tk::console::MatchQuote %W promptEnd
}
}
bind PostConsole <KeyPress> {
if {"%A" != ""} {
::tk::console::TagProc %W
}
break
}
}
# ::tk::ConsoleInsert --
# Insert a string into a text at the point of the insertion cursor.
# If there is a selection in the text, and it covers the point of the
# insertion cursor, then delete the selection before inserting. Insertion
# is restricted to the prompt area.
#
# Arguments:
# w - The text window in which to insert the string
# s - The string to insert (usually just a single character)
proc ::tk::ConsoleInsert {w s} {
if {[string equal $s ""]} {
return
}
catch {
if {[$w compare sel.first <= insert]
&& [$w compare sel.last >= insert]} {
$w tag remove sel sel.first promptEnd
$w delete sel.first sel.last
}
}
if {[$w compare insert < promptEnd]} {
$w mark set insert end
}
$w insert insert $s {input stdin}
$w see insert
}
# ::tk::ConsoleOutput --
#
# This routine is called directly by ConsolePutsCmd to cause a string
# to be displayed in the console.
#
# Arguments:
# dest - The output tag to be used: either "stderr" or "stdout".
# string - The string to be displayed.
proc ::tk::ConsoleOutput {dest string} {
set w .console
$w insert output $string $dest
::tk::console::ConstrainBuffer $w $::tk::console::maxLines
$w see insert
}
# ::tk::ConsoleExit --
#
# This routine is called by ConsoleEventProc when the main window of
# the application is destroyed. Don't call exit - that probably already
# happened. Just delete our window.
#
# Arguments:
# None.
proc ::tk::ConsoleExit {} {
destroy .
}
# ::tk::ConsoleAbout --
#
# This routine displays an About box to show Tcl/Tk version info.
#
# Arguments:
# None.
proc ::tk::ConsoleAbout {} {
tk_messageBox -type ok -message "[mc {Tcl for Windows}]
Tcl $::tcl_patchLevel
Tk $::tk_patchLevel"
}
# ::tk::console::TagProc --
#
# Tags a procedure in the console if it's recognized
# This procedure is not perfect. However, making it perfect wastes
# too much CPU time...
#
# Arguments:
# w - console text widget
proc ::tk::console::TagProc w {
if {!$::tk::console::magicKeys} { return }
set exp "\[^\\\\\]\[\[ \t\n\r\;{}\"\$\]"
set i [$w search -backwards -regexp $exp insert-1c promptEnd-1c]
if {$i == ""} {set i promptEnd} else {append i +2c}
regsub -all "\[\[\\\\\\?\\*\]" [$w get $i "insert-1c wordend"] {\\\0} c
if {[llength [EvalAttached [list info commands $c]]]} {
$w tag add proc $i "insert-1c wordend"
} else {
$w tag remove proc $i "insert-1c wordend"
}
if {[llength [EvalAttached [list info vars $c]]]} {
$w tag add var $i "insert-1c wordend"
} else {
$w tag remove var $i "insert-1c wordend"
}
}
# ::tk::console::MatchPair --
#
# Blinks a matching pair of characters
# c2 is assumed to be at the text index 'insert'.
# This proc is really loopy and took me an hour to figure out given
# all possible combinations with escaping except for escaped \'s.
# It doesn't take into account possible commenting... Oh well. If
# anyone has something better, I'd like to see/use it. This is really
# only efficient for small contexts.
#
# Arguments:
# w - console text widget
# c1 - first char of pair
# c2 - second char of pair
#
# Calls: ::tk::console::Blink
proc ::tk::console::MatchPair {w c1 c2 {lim 1.0}} {
if {!$::tk::console::magicKeys} { return }
if {[string compare {} [set ix [$w search -back $c1 insert $lim]]]} {
while {
[string match {\\} [$w get $ix-1c]] &&
[string compare {} [set ix [$w search -back $c1 $ix-1c $lim]]]
} {}
set i1 insert-1c
while {[string compare {} $ix]} {
set i0 $ix
set j 0
while {[string compare {} [set i0 [$w search $c2 $i0 $i1]]]} {
append i0 +1c
if {[string match {\\} [$w get $i0-2c]]} continue
incr j
}
if {!$j} break
set i1 $ix
while {$j && [string compare {} \
[set ix [$w search -back $c1 $ix $lim]]]} {
if {[string match {\\} [$w get $ix-1c]]} continue
incr j -1
}
}
if {[string match {} $ix]} { set ix [$w index $lim] }
} else { set ix [$w index $lim] }
if {$::tk::console::blinkRange} {
Blink $w $ix [$w index insert]
} else {
Blink $w $ix $ix+1c [$w index insert-1c] [$w index insert]
}
}
# ::tk::console::MatchQuote --
#
# Blinks between matching quotes.
# Blinks just the quote if it's unmatched, otherwise blinks quoted string
# The quote to match is assumed to be at the text index 'insert'.
#
# Arguments:
# w - console text widget
#
# Calls: ::tk::console::Blink
proc ::tk::console::MatchQuote {w {lim 1.0}} {
if {!$::tk::console::magicKeys} { return }
set i insert-1c
set j 0
while {[string compare [set i [$w search -back \" $i $lim]] {}]} {
if {[string match {\\} [$w get $i-1c]]} continue
if {!$j} {set i0 $i}
incr j
}
if {$j&1} {
if {$::tk::console::blinkRange} {
Blink $w $i0 [$w index insert]
} else {
Blink $w $i0 $i0+1c [$w index insert-1c] [$w index insert]
}
} else {
Blink $w [$w index insert-1c] [$w index insert]
}
}
# ::tk::console::Blink --
#
# Blinks between n index pairs for a specified duration.
#
# Arguments:
# w - console text widget
# i1 - start index to blink region
# i2 - end index of blink region
# dur - duration in usecs to blink for
#
# Outputs:
# blinks selected characters in $w
proc ::tk::console::Blink {w args} {
eval [list $w tag add blink] $args
after $::tk::console::blinkTime [list $w] tag remove blink $args
}
# ::tk::console::ConstrainBuffer --
#
# This limits the amount of data in the text widget
# Called by Prompt and ConsoleOutput
#
# Arguments:
# w - console text widget
# size - # of lines to constrain to
#
# Outputs:
# may delete data in console widget
proc ::tk::console::ConstrainBuffer {w size} {
if {[$w index end] > $size} {
$w delete 1.0 [expr {int([$w index end])-$size}].0
}
}
# ::tk::console::Expand --
#
# Arguments:
# ARGS: w - text widget in which to expand str
# type - type of expansion (path / proc / variable)
#
# Calls: ::tk::console::Expand(Pathname|Procname|Variable)
#
# Outputs: The string to match is expanded to the longest possible match.
# If ::tk::console::showMatches is non-zero and the longest match
# equaled the string to expand, then all possible matches are
# output to stdout. Triggers bell if no matches are found.
#
# Returns: number of matches found
proc ::tk::console::Expand {w {type ""}} {
set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"\\\\\$\]"
set tmp [$w search -backwards -regexp $exp insert-1c promptEnd-1c]
if {$tmp == ""} {set tmp promptEnd} else {append tmp +2c}
if {[$w compare $tmp >= insert]} { return }
set str [$w get $tmp insert]
switch -glob $type {
path* { set res [ExpandPathname $str] }
proc* { set res [ExpandProcname $str] }
var* { set res [ExpandVariable $str] }
default {
set res {}
foreach t {Pathname Procname Variable} {
if {![catch {Expand$t $str} res] && ($res != "")} { break }
}
}
}
set len [llength $res]
if {$len} {
set repl [lindex $res 0]
$w delete $tmp insert
$w insert $tmp $repl {input stdin}
if {($len > 1) && $::tk::console::showMatches \
&& [string equal $repl $str]} {
puts stdout [lsort [lreplace $res 0 0]]
}
} else { bell }
return [incr len -1]
}
# ::tk::console::ExpandPathname --
#
# Expand a file pathname based on $str
# This is based on UNIX file name conventions
#
# Arguments:
# str - partial file pathname to expand
#
# Calls: ::tk::console::ExpandBestMatch
#
# Returns: list containing longest unique match followed by all the
# possible further matches
proc ::tk::console::ExpandPathname str {
set pwd [EvalAttached pwd]
if {[catch {EvalAttached [list cd [file dirname $str]]} err]} {
return -code error $err
}
set dir [file tail $str]
## Check to see if it was known to be a directory and keep the trailing
## slash if so (file tail cuts it off)
if {[string match */ $str]} { append dir / }
if {[catch {lsort [EvalAttached [list glob $dir*]]} m]} {
set match {}
} else {
if {[llength $m] > 1} {
global tcl_platform
if {[string match windows $tcl_platform(platform)]} {
## Windows is screwy because it's case insensitive
set tmp [ExpandBestMatch [string tolower $m] \
[string tolower $dir]]
## Don't change case if we haven't changed the word
if {[string length $dir]==[string length $tmp]} {
set tmp $dir
}
} else {
set tmp [ExpandBestMatch $m $dir]
}
if {[string match ?*/* $str]} {
set tmp [file dirname $str]/$tmp
} elseif {[string match /* $str]} {
set tmp /$tmp
}
regsub -all { } $tmp {\\ } tmp
set match [linsert $m 0 $tmp]
} else {
## This may look goofy, but it handles spaces in path names
eval append match $m
if {[file isdir $match]} {append match /}
if {[string match ?*/* $str]} {
set match [file dirname $str]/$match
} elseif {[string match /* $str]} {
set match /$match
}
regsub -all { } $match {\\ } match
## Why is this one needed and the ones below aren't!!
set match [list $match]
}
}
EvalAttached [list cd $pwd]
return $match
}
# ::tk::console::ExpandProcname --
#
# Expand a tcl proc name based on $str
#
# Arguments:
# str - partial proc name to expand
#
# Calls: ::tk::console::ExpandBestMatch
#
# Returns: list containing longest unique match followed by all the
# possible further matches
proc ::tk::console::ExpandProcname str {
set match [EvalAttached [list info commands $str*]]
if {[llength $match] == 0} {
set ns [EvalAttached \
"namespace children \[namespace current\] [list $str*]"]
if {[llength $ns]==1} {
set match [EvalAttached [list info commands ${ns}::*]]
} else {
set match $ns
}
}
if {[llength $match] > 1} {
regsub -all { } [ExpandBestMatch $match $str] {\\ } str
set match [linsert $match 0 $str]
} else {
regsub -all { } $match {\\ } match
}
return $match
}
# ::tk::console::ExpandVariable --
#
# Expand a tcl variable name based on $str
#
# Arguments:
# str - partial tcl var name to expand
#
# Calls: ::tk::console::ExpandBestMatch
#
# Returns: list containing longest unique match followed by all the
# possible further matches
proc ::tk::console::ExpandVariable str {
if {[regexp {([^\(]*)\((.*)} $str junk ary str]} {
## Looks like they're trying to expand an array.
set match [EvalAttached [list array names $ary $str*]]
if {[llength $match] > 1} {
set vars $ary\([ExpandBestMatch $match $str]
foreach var $match {lappend vars $ary\($var\)}
return $vars
} else {set match $ary\($match\)}
## Space transformation avoided for array names.
} else {
set match [EvalAttached [list info vars $str*]]
if {[llength $match] > 1} {
regsub -all { } [ExpandBestMatch $match $str] {\\ } str
set match [linsert $match 0 $str]
} else {
regsub -all { } $match {\\ } match
}
}
return $match
}
# ::tk::console::ExpandBestMatch --
#
# Finds the best unique match in a list of names.
# The extra $e in this argument allows us to limit the innermost loop a little
# further. This improves speed as $l becomes large or $e becomes long.
#
# Arguments:
# l - list to find best unique match in
# e - currently best known unique match
#
# Returns: longest unique match in the list
proc ::tk::console::ExpandBestMatch {l {e {}}} {
set ec [lindex $l 0]
if {[llength $l]>1} {
set e [string length $e]; incr e -1
set ei [string length $ec]; incr ei -1
foreach l $l {
while {$ei>=$e && [string first $ec $l]} {
set ec [string range $ec 0 [incr ei -1]]
}
}
}
return $ec
}
# now initialize the console
::tk::ConsoleInit
gradint-build/PocketPC/Program Files/lib/tk8.4/dialog.tcl deleted 100644 → 0
View file @ 14df51ec
# dialog.tcl --
#
# This file defines the procedure tk_dialog, which creates a dialog
# box containing a bitmap, a message, and one or more buttons.
#
# RCS: @(#) $Id: dialog.tcl,v 1.14 2002/08/31 06:12:28 das Exp $
#
# Copyright (c) 1992-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#
# ::tk_dialog:
#
# This procedure displays a dialog box, waits for a button in the dialog
# to be invoked, then returns the index of the selected button. If the
# dialog somehow gets destroyed, -1 is returned.
#
# Arguments:
# w - Window to use for dialog top-level.
# title - Title to display in dialog's decorative frame.
# text - Message to display in dialog.
# bitmap - Bitmap to display in dialog (empty string means none).
# default - Index of button that is to display the default ring
# (-1 means none).
# args - One or more strings to display in buttons across the
# bottom of the dialog box.
proc ::tk_dialog {w title text bitmap default args} {
global tcl_platform
variable ::tk::Priv
# Check that $default was properly given
if {[string is int $default]} {
if {$default >= [llength $args]} {
return -code error "default button index greater than number of\
buttons specified for tk_dialog"
}
} elseif {[string equal {} $default]} {
set default -1
} else {
set default [lsearch -exact $args $default]
}
# 1. Create the top-level window and divide it into top
# and bottom parts.
catch {destroy $w}
toplevel $w -class Dialog
wm title $w $title
wm iconname $w Dialog
wm protocol $w WM_DELETE_WINDOW { }
# Dialog boxes should be transient with respect to their parent,
# so that they will always stay on top of their parent window. However,
# some window managers will create the window as withdrawn if the parent
# window is withdrawn or iconified. Combined with the grab we put on the
# window, this can hang the entire application. Therefore we only make
# the dialog transient if the parent is viewable.
#
if {[winfo viewable [winfo toplevel [winfo parent $w]]] } {
wm transient $w [winfo toplevel [winfo parent $w]]
}
if {[string equal $tcl_platform(platform) "macintosh"]
|| [string equal [tk windowingsystem] "aqua"]} {
::tk::unsupported::MacWindowStyle style $w dBoxProc
}
frame $w.bot
frame $w.top
if {[string equal [tk windowingsystem] "x11"]} {
$w.bot configure -relief raised -bd 1
$w.top configure -relief raised -bd 1
}
pack $w.bot -side bottom -fill both
pack $w.top -side top -fill both -expand 1
# 2. Fill the top part with bitmap and message (use the option
# database for -wraplength and -font so that they can be
# overridden by the caller).
option add *Dialog.msg.wrapLength 3i widgetDefault
if {[string equal $tcl_platform(platform) "macintosh"]
|| [string equal [tk windowingsystem] "aqua"]} {
option add *Dialog.msg.font system widgetDefault
} else {
option add *Dialog.msg.font {Times 12} widgetDefault
}
label $w.msg -justify left -text $text
pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
if {[string compare $bitmap ""]} {
if {([string equal $tcl_platform(platform) "macintosh"]
|| [string equal [tk windowingsystem] "aqua"]) &&\
[string equal $bitmap "error"]} {
set bitmap "stop"
}
label $w.bitmap -bitmap $bitmap
pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
}
# 3. Create a row of buttons at the bottom of the dialog.
set i 0
foreach but $args {
button $w.button$i -text $but -command [list set ::tk::Priv(button) $i]
if {$i == $default} {
$w.button$i configure -default active
} else {
$w.button$i configure -default normal
}
grid $w.button$i -in $w.bot -column $i -row 0 -sticky ew \
-padx 10 -pady 4
grid columnconfigure $w.bot $i
# We boost the size of some Mac buttons for l&f
if {[string equal $tcl_platform(platform) "macintosh"]
|| [string equal [tk windowingsystem] "aqua"]} {
set tmp [string tolower $but]
if {[string equal $tmp "ok"] || [string equal $tmp "cancel"]} {
grid columnconfigure $w.bot $i -minsize [expr {59 + 20}]
}
}
incr i
}
# 4. Create a binding for <Return> on the dialog if there is a
# default button.
if {$default >= 0} {
bind $w <Return> "
[list $w.button$default] configure -state active -relief sunken
update idletasks
after 100
set ::tk::Priv(button) $default
"
}
# 5. Create a <Destroy> binding for the window that sets the
# button variable to -1; this is needed in case something happens
# that destroys the window, such as its parent window being destroyed.
bind $w <Destroy> {set ::tk::Priv(button) -1}
# 6. Withdraw the window, then update all the geometry information
# so we know how big it wants to be, then center the window in the
# display and de-iconify it.
wm withdraw $w
update idletasks
set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
- [winfo vrootx [winfo parent $w]]}]
set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
- [winfo vrooty [winfo parent $w]]}]
wm geom $w +$x+$y
wm deiconify $w
# 7. Set a grab and claim the focus too.
set oldFocus [focus]
set oldGrab [grab current $w]
if {[string compare $oldGrab ""]} {
set grabStatus [grab status $oldGrab]
}
grab $w
if {$default >= 0} {
focus $w.button$default
} else {
focus $w
}
# 8. Wait for the user to respond, then restore the focus and
# return the index of the selected button. Restore the focus
# before deleting the window, since otherwise the window manager
# may take the focus away so we can't redirect it. Finally,
# restore any grab that was in effect.
vwait ::tk::Priv(button)
catch {focus $oldFocus}
catch {
# It's possible that the window has already been destroyed,
# hence this "catch". Delete the Destroy handler so that
# Priv(button) doesn't get reset by it.
bind $w <Destroy> {}
destroy $w
}
if {[string compare $oldGrab ""]} {
if {[string compare $grabStatus "global"]} {
grab $oldGrab
} else {
grab -global $oldGrab
}
}
return $Priv(button)
}
gradint-build/PocketPC/Program Files/lib/tk8.4/entry.tcl deleted 100644 → 0
View file @ 14df51ec
# entry.tcl --
#
# This file defines the default bindings for Tk entry widgets and provides
# procedures that help in implementing those bindings.
#
# RCS: @(#) $Id: entry.tcl,v 1.21 2003/01/23 23:30:11 drh Exp $
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#-------------------------------------------------------------------------
# Elements of tk::Priv that are used in this file:
#
# afterId - If non-null, it means that auto-scanning is underway
# and it gives the "after" id for the next auto-scan
# command to be executed.
# mouseMoved - Non-zero means the mouse has moved a significant
# amount since the button went down (so, for example,
# start dragging out a selection).
# pressX - X-coordinate at which the mouse button was pressed.
# selectMode - The style of selection currently underway:
# char, word, or line.
# x, y - Last known mouse coordinates for scanning
# and auto-scanning.
# data - Used for Cut and Copy
#-------------------------------------------------------------------------
#-------------------------------------------------------------------------
# The code below creates the default class bindings for entries.
#-------------------------------------------------------------------------
bind Entry <<Cut>> {
if {![catch {tk::EntryGetSelection %W} tk::Priv(data)]} {
clipboard clear -displayof %W
clipboard append -displayof %W $tk::Priv(data)
%W delete sel.first sel.last
unset tk::Priv(data)
}
}
bind Entry <<Copy>> {
if {![catch {tk::EntryGetSelection %W} tk::Priv(data)]} {
clipboard clear -displayof %W
clipboard append -displayof %W $tk::Priv(data)
unset tk::Priv(data)
}
}
bind Entry <<Paste>> {
global tcl_platform
catch {
if {[string compare [tk windowingsystem] "x11"]} {
catch {
%W delete sel.first sel.last
}
}
%W insert insert [::tk::GetSelection %W CLIPBOARD]
tk::EntrySeeInsert %W
}
}
bind Entry <<Clear>> {
%W delete sel.first sel.last
}
bind Entry <<PasteSelection>> {
if {$tk_strictMotif || ![info exists tk::Priv(mouseMoved)]
|| !$tk::Priv(mouseMoved)} {
tk::EntryPaste %W %x
}
}
# Standard Motif bindings:
bind Entry <1> {
tk::EntryButton1 %W %x
%W selection clear
}
bind Entry <B1-Motion> {
set tk::Priv(x) %x
tk::EntryMouseSelect %W %x
}
bind Entry <Double-1> {
set tk::Priv(selectMode) word
tk::EntryMouseSelect %W %x
catch {%W icursor sel.last}
}
bind Entry <Triple-1> {
set tk::Priv(selectMode) line
tk::EntryMouseSelect %W %x
catch {%W icursor sel.last}
}
bind Entry <Shift-1> {
set tk::Priv(selectMode) char
%W selection adjust @%x
}
bind Entry <Double-Shift-1> {
set tk::Priv(selectMode) word
tk::EntryMouseSelect %W %x
}
bind Entry <Triple-Shift-1> {
set tk::Priv(selectMode) line
tk::EntryMouseSelect %W %x
}
bind Entry <B1-Leave> {
set tk::Priv(x) %x
tk::EntryAutoScan %W
}
bind Entry <B1-Enter> {
tk::CancelRepeat
}
bind Entry <ButtonRelease-1> {
tk::CancelRepeat
}
bind Entry <Control-1> {
%W icursor @%x
}
bind Entry <Left> {
tk::EntrySetCursor %W [expr {[%W index insert] - 1}]
}
bind Entry <Right> {
tk::EntrySetCursor %W [expr {[%W index insert] + 1}]
}
bind Entry <Shift-Left> {
tk::EntryKeySelect %W [expr {[%W index insert] - 1}]
tk::EntrySeeInsert %W
}
bind Entry <Shift-Right> {
tk::EntryKeySelect %W [expr {[%W index insert] + 1}]
tk::EntrySeeInsert %W
}
bind Entry <Control-Left> {
tk::EntrySetCursor %W [tk::EntryPreviousWord %W insert]
}
bind Entry <Control-Right> {
tk::EntrySetCursor %W [tk::EntryNextWord %W insert]
}
bind Entry <Shift-Control-Left> {
tk::EntryKeySelect %W [tk::EntryPreviousWord %W insert]
tk::EntrySeeInsert %W
}
bind Entry <Shift-Control-Right> {
tk::EntryKeySelect %W [tk::EntryNextWord %W insert]
tk::EntrySeeInsert %W
}
bind Entry <Home> {
tk::EntrySetCursor %W 0
}
bind Entry <Shift-Home> {
tk::EntryKeySelect %W 0
tk::EntrySeeInsert %W
}
bind Entry <End> {
tk::EntrySetCursor %W end
}
bind Entry <Shift-End> {
tk::EntryKeySelect %W end
tk::EntrySeeInsert %W
}
bind Entry <Delete> {
if {[%W selection present]} {
%W delete sel.first sel.last
} else {
%W delete insert
}
}
bind Entry <BackSpace> {
tk::EntryBackspace %W
}
bind Entry <Control-space> {
%W selection from insert
}
bind Entry <Select> {
%W selection from insert
}
bind Entry <Control-Shift-space> {
%W selection adjust insert
}
bind Entry <Shift-Select> {
%W selection adjust insert
}
bind Entry <Control-slash> {
%W selection range 0 end
}
bind Entry <Control-backslash> {
%W selection clear
}
bind Entry <KeyPress> {
tk::CancelRepeat
tk::EntryInsert %W %A
}
# Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
# Otherwise, if a widget binding for one of these is defined, the
# <KeyPress> class binding will also fire and insert the character,
# which is wrong. Ditto for Escape, Return, and Tab.
bind Entry <Alt-KeyPress> {# nothing}
bind Entry <Meta-KeyPress> {# nothing}
bind Entry <Control-KeyPress> {# nothing}
bind Entry <Escape> {# nothing}
bind Entry <Return> {# nothing}
bind Entry <KP_Enter> {# nothing}
bind Entry <Tab> {# nothing}
if {[string equal [tk windowingsystem] "classic"]
|| [string equal [tk windowingsystem] "aqua"]} {
bind Entry <Command-KeyPress> {# nothing}
}
# On Windows, paste is done using Shift-Insert. Shift-Insert already
# generates the <<Paste>> event, so we don't need to do anything here.
if {[string compare $tcl_platform(platform) "windows"]} {
bind Entry <Insert> {
catch {tk::EntryInsert %W [::tk::GetSelection %W PRIMARY]}
}
}
# Additional emacs-like bindings:
bind Entry <Control-a> {
if {!$tk_strictMotif} {
tk::EntrySetCursor %W 0
}
}
bind Entry <Control-b> {
if {!$tk_strictMotif} {
tk::EntrySetCursor %W [expr {[%W index insert] - 1}]
}
}
bind Entry <Control-d> {
if {!$tk_strictMotif} {
%W delete insert
}
}
bind Entry <Control-e> {
if {!$tk_strictMotif} {
tk::EntrySetCursor %W end
}
}
bind Entry <Control-f> {
if {!$tk_strictMotif} {
tk::EntrySetCursor %W [expr {[%W index insert] + 1}]
}
}
bind Entry <Control-h> {
if {!$tk_strictMotif} {
tk::EntryBackspace %W
}
}
bind Entry <Control-k> {
if {!$tk_strictMotif} {
%W delete insert end
}
}
bind Entry <Control-t> {
if {!$tk_strictMotif} {
tk::EntryTranspose %W
}
}
bind Entry <Meta-b> {
if {!$tk_strictMotif} {
tk::EntrySetCursor %W [tk::EntryPreviousWord %W insert]
}
}
bind Entry <Meta-d> {
if {!$tk_strictMotif} {
%W delete insert [tk::EntryNextWord %W insert]
}
}
bind Entry <Meta-f> {
if {!$tk_strictMotif} {
tk::EntrySetCursor %W [tk::EntryNextWord %W insert]
}
}
bind Entry <Meta-BackSpace> {
if {!$tk_strictMotif} {
%W delete [tk::EntryPreviousWord %W insert] insert
}
}
bind Entry <Meta-Delete> {
if {!$tk_strictMotif} {
%W delete [tk::EntryPreviousWord %W insert] insert
}
}
# A few additional bindings of my own.
bind Entry <2> {
if {!$tk_strictMotif} {
::tk::EntryScanMark %W %x
}
}
bind Entry <B2-Motion> {
if {!$tk_strictMotif} {
::tk::EntryScanDrag %W %x
}
}
# ::tk::EntryClosestGap --
# Given x and y coordinates, this procedure finds the closest boundary
# between characters to the given coordinates and returns the index
# of the character just after the boundary.
#
# Arguments:
# w - The entry window.
# x - X-coordinate within the window.
proc ::tk::EntryClosestGap {w x} {
set pos [$w index @$x]
set bbox [$w bbox $pos]
if {($x - [lindex $bbox 0]) < ([lindex $bbox 2]/2)} {
return $pos
}
incr pos
}
# ::tk::EntryButton1 --
# This procedure is invoked to handle button-1 presses in entry
# widgets. It moves the insertion cursor, sets the selection anchor,
# and claims the input focus.
#
# Arguments:
# w - The entry window in which the button was pressed.
# x - The x-coordinate of the button press.
proc ::tk::EntryButton1 {w x} {
variable ::tk::Priv
set Priv(selectMode) char
set Priv(mouseMoved) 0
set Priv(pressX) $x
$w icursor [EntryClosestGap $w $x]
$w selection from insert
if {[string compare "disabled" [$w cget -state]]} {focus $w}
}
# ::tk::EntryMouseSelect --
# This procedure is invoked when dragging out a selection with
# the mouse. Depending on the selection mode (character, word,
# line) it selects in different-sized units. This procedure
# ignores mouse motions initially until the mouse has moved from
# one character to another or until there have been multiple clicks.
#
# Arguments:
# w - The entry window in which the button was pressed.
# x - The x-coordinate of the mouse.
proc ::tk::EntryMouseSelect {w x} {
variable ::tk::Priv
set cur [EntryClosestGap $w $x]
set anchor [$w index anchor]
if {($cur != $anchor) || (abs($Priv(pressX) - $x) >= 3)} {
set Priv(mouseMoved) 1
}
switch $Priv(selectMode) {
char {
if {$Priv(mouseMoved)} {
if {$cur < $anchor} {
$w selection range $cur $anchor
} elseif {$cur > $anchor} {
$w selection range $anchor $cur
} else {
$w selection clear
}
}
}
word {
if {$cur < [$w index anchor]} {
set before [tcl_wordBreakBefore [$w get] $cur]
set after [tcl_wordBreakAfter [$w get] [expr {$anchor-1}]]
} else {
set before [tcl_wordBreakBefore [$w get] $anchor]
set after [tcl_wordBreakAfter [$w get] [expr {$cur - 1}]]
}
if {$before < 0} {
set before 0
}
if {$after < 0} {
set after end
}
$w selection range $before $after
}
line {
$w selection range 0 end
}
}
if {$Priv(mouseMoved)} {
$w icursor $cur
}
update idletasks
}
# ::tk::EntryPaste --
# This procedure sets the insertion cursor to the current mouse position,
# pastes the selection there, and sets the focus to the window.
#
# Arguments:
# w - The entry window.
# x - X position of the mouse.
proc ::tk::EntryPaste {w x} {
$w icursor [EntryClosestGap $w $x]
catch {$w insert insert [::tk::GetSelection $w PRIMARY]}
if {[string compare "disabled" [$w cget -state]]} {focus $w}
}
# ::tk::EntryAutoScan --
# This procedure is invoked when the mouse leaves an entry window
# with button 1 down. It scrolls the window left or right,
# depending on where the mouse is, and reschedules itself as an
# "after" command so that the window continues to scroll until the
# mouse moves back into the window or the mouse button is released.
#
# Arguments:
# w - The entry window.
proc ::tk::EntryAutoScan {w} {
variable ::tk::Priv
set x $Priv(x)
if {![winfo exists $w]} return
if {$x >= [winfo width $w]} {
$w xview scroll 2 units
EntryMouseSelect $w $x
} elseif {$x < 0} {
$w xview scroll -2 units
EntryMouseSelect $w $x
}
set Priv(afterId) [after 50 [list tk::EntryAutoScan $w]]
}
# ::tk::EntryKeySelect --
# This procedure is invoked when stroking out selections using the
# keyboard. It moves the cursor to a new position, then extends
# the selection to that position.
#
# Arguments:
# w - The entry window.
# new - A new position for the insertion cursor (the cursor hasn't
# actually been moved to this position yet).
proc ::tk::EntryKeySelect {w new} {
if {![$w selection present]} {
$w selection from insert
$w selection to $new
} else {
$w selection adjust $new
}
$w icursor $new
}
# ::tk::EntryInsert --
# Insert a string into an entry at the point of the insertion cursor.
# If there is a selection in the entry, and it covers the point of the
# insertion cursor, then delete the selection before inserting.
#
# Arguments:
# w - The entry window in which to insert the string
# s - The string to insert (usually just a single character)
proc ::tk::EntryInsert {w s} {
if {[string equal $s ""]} {
return
}
catch {
set insert [$w index insert]
if {([$w index sel.first] <= $insert)
&& ([$w index sel.last] >= $insert)} {
$w delete sel.first sel.last
}
}
$w insert insert $s
EntrySeeInsert $w
}
# ::tk::EntryBackspace --
# Backspace over the character just before the insertion cursor.
# If backspacing would move the cursor off the left edge of the
# window, reposition the cursor at about the middle of the window.
#
# Arguments:
# w - The entry window in which to backspace.
proc ::tk::EntryBackspace w {
if {[$w selection present]} {
$w delete sel.first sel.last
} else {
set x [expr {[$w index insert] - 1}]
if {$x >= 0} {$w delete $x}
if {[$w index @0] >= [$w index insert]} {
set range [$w xview]
set left [lindex $range 0]
set right [lindex $range 1]
$w xview moveto [expr {$left - ($right - $left)/2.0}]
}
}
}
# ::tk::EntrySeeInsert --
# Make sure that the insertion cursor is visible in the entry window.
# If not, adjust the view so that it is.
#
# Arguments:
# w - The entry window.
proc ::tk::EntrySeeInsert w {
set c [$w index insert]
if {($c < [$w index @0]) || ($c > [$w index @[winfo width $w]])} {
$w xview $c
}
}
# ::tk::EntrySetCursor -
# Move the insertion cursor to a given position in an entry. Also
# clears the selection, if there is one in the entry, and makes sure
# that the insertion cursor is visible.
#
# Arguments:
# w - The entry window.
# pos - The desired new position for the cursor in the window.
proc ::tk::EntrySetCursor {w pos} {
$w icursor $pos
$w selection clear
EntrySeeInsert $w
}
# ::tk::EntryTranspose -
# This procedure implements the "transpose" function for entry widgets.
# It tranposes the characters on either side of the insertion cursor,
# unless the cursor is at the end of the line. In this case it
# transposes the two characters to the left of the cursor. In either
# case, the cursor ends up to the right of the transposed characters.
#
# Arguments:
# w - The entry window.
proc ::tk::EntryTranspose w {
set i [$w index insert]
if {$i < [$w index end]} {
incr i
}
set first [expr {$i-2}]
if {$first < 0} {
return
}
set data [$w get]
set new [string index $data [expr {$i-1}]][string index $data $first]
$w delete $first $i
$w insert insert $new
EntrySeeInsert $w
}
# ::tk::EntryNextWord --
# Returns the index of the next word position after a given position in the
# entry. The next word is platform dependent and may be either the next
# end-of-word position or the next start-of-word position after the next
# end-of-word position.
#
# Arguments:
# w - The entry window in which the cursor is to move.
# start - Position at which to start search.
if {[string equal $tcl_platform(platform) "windows"]} {
proc ::tk::EntryNextWord {w start} {
set pos [tcl_endOfWord [$w get] [$w index $start]]
if {$pos >= 0} {
set pos [tcl_startOfNextWord [$w get] $pos]
}
if {$pos < 0} {
return end
}
return $pos
}
} else {
proc ::tk::EntryNextWord {w start} {
set pos [tcl_endOfWord [$w get] [$w index $start]]
if {$pos < 0} {
return end
}
return $pos
}
}
# ::tk::EntryPreviousWord --
#
# Returns the index of the previous word position before a given
# position in the entry.
#
# Arguments:
# w - The entry window in which the cursor is to move.
# start - Position at which to start search.
proc ::tk::EntryPreviousWord {w start} {
set pos [tcl_startOfPreviousWord [$w get] [$w index $start]]
if {$pos < 0} {
return 0
}
return $pos
}
# ::tk::EntryScanMark --
#
# Marks the start of a possible scan drag operation
#
# Arguments:
# w - The entry window from which the text to get
# x - x location on screen
proc ::tk::EntryScanMark {w x} {
$w scan mark $x
set ::tk::Priv(x) $x
set ::tk::Priv(y) 0 ; # not used
set ::tk::Priv(mouseMoved) 0
}
# ::tk::EntryScanDrag --
#
# Marks the start of a possible scan drag operation
#
# Arguments:
# w - The entry window from which the text to get
# x - x location on screen
proc ::tk::EntryScanDrag {w x} {
# Make sure these exist, as some weird situations can trigger the
# motion binding without the initial press. [Bug #220269]
if {![info exists ::tk::Priv(x)]} { set ::tk::Priv(x) $x }
# allow for a delta
if {abs($x-$::tk::Priv(x)) > 2} {
set ::tk::Priv(mouseMoved) 1
}
$w scan dragto $x
}
# ::tk::EntryGetSelection --
#
# Returns the selected text of the entry with respect to the -show option.
#
# Arguments:
# w - The entry window from which the text to get
proc ::tk::EntryGetSelection {w} {
set entryString [string range [$w get] [$w index sel.first] \
[expr {[$w index sel.last] - 1}]]
if {[string compare [$w cget -show] ""]} {
return [string repeat [string index [$w cget -show] 0] \
[string length $entryString]]
}
return $entryString
}